From 41cd089b03c52779052d850f8b87eb220ff9a20c Mon Sep 17 00:00:00 2001 From: Chad Granum Date: Tue, 28 Nov 2023 16:20:18 -0800 Subject: [PATCH] Bulk Commit runner/run/auditor/preload --- lib/Test2/Harness/Auditor.pm | 176 -- lib/Test2/Harness/Auditor/Watcher.pm | 488 ----- lib/Test2/Harness/IPC/Process.pm | 134 -- .../Harness/{Auditor => Log}/TimeTracker.pm | 10 +- lib/Test2/Harness/Preload.pm | 520 +++++ lib/Test2/Harness/Preload/Stage.pm | 164 ++ lib/Test2/Harness/{Runner => }/Reloader.pm | 274 ++- lib/Test2/Harness/Reloader/Inotify2.pm | 101 + lib/Test2/Harness/Reloader/Stat.pm | 111 + lib/Test2/Harness/Run.pm | 239 +-- lib/Test2/Harness/Run/Auditor.pm | 288 +++ lib/Test2/Harness/Run/Job.pm | 92 + lib/Test2/Harness/Runner.pm | 710 +------ lib/Test2/Harness/Runner/Constants.pm | 72 - lib/Test2/Harness/Runner/DepTracer.pm | 283 --- lib/Test2/Harness/Runner/Job.pm | 828 -------- lib/Test2/Harness/Runner/Preload.pm | 564 +---- lib/Test2/Harness/Runner/Preload/Stage.pm | 154 +- lib/Test2/Harness/Runner/Preloader.pm | 665 ------ lib/Test2/Harness/Runner/Preloader/Stage.pm | 62 - lib/Test2/Harness/Runner/Preloading.pm | 196 ++ lib/Test2/Harness/Runner/Preloading/Stage.pm | 497 +++++ lib/Test2/Harness/Runner/Resource.pm | 597 ------ lib/Test2/Harness/Runner/Resource/JobCount.pm | 168 -- .../Harness/Runner/Resource/SharedJobSlots.pm | 432 ---- .../Runner/Resource/SharedJobSlots/Config.pm | 178 -- .../Runner/Resource/SharedJobSlots/State.pm | 602 ------ lib/Test2/Harness/Runner/Run.pm | 104 - lib/Test2/Harness/Runner/Spawn.pm | 89 - lib/Test2/Harness/Runner/State.pm | 865 -------- lib/Test2/Harness/Scheduler.pm | 46 + lib/Test2/Harness/Scheduler/Default.pm | 1844 +++++++++++++++++ lib/Test2/Harness/Scheduler/Default/Run.pm | 46 + lib/Test2/Harness/Util/IPC.pm | 326 --- 34 files changed, 4329 insertions(+), 7596 deletions(-) delete mode 100644 lib/Test2/Harness/Auditor.pm delete mode 100644 lib/Test2/Harness/Auditor/Watcher.pm delete mode 100644 lib/Test2/Harness/IPC/Process.pm rename lib/Test2/Harness/{Auditor => Log}/TimeTracker.pm (97%) create mode 100644 lib/Test2/Harness/Preload.pm create mode 100644 lib/Test2/Harness/Preload/Stage.pm rename lib/Test2/Harness/{Runner => }/Reloader.pm (54%) create mode 100644 lib/Test2/Harness/Reloader/Inotify2.pm create mode 100644 lib/Test2/Harness/Reloader/Stat.pm create mode 100644 lib/Test2/Harness/Run/Auditor.pm create mode 100644 lib/Test2/Harness/Run/Job.pm delete mode 100644 lib/Test2/Harness/Runner/Constants.pm delete mode 100644 lib/Test2/Harness/Runner/DepTracer.pm delete mode 100644 lib/Test2/Harness/Runner/Job.pm delete mode 100644 lib/Test2/Harness/Runner/Preloader.pm delete mode 100644 lib/Test2/Harness/Runner/Preloader/Stage.pm create mode 100644 lib/Test2/Harness/Runner/Preloading.pm create mode 100644 lib/Test2/Harness/Runner/Preloading/Stage.pm delete mode 100644 lib/Test2/Harness/Runner/Resource.pm delete mode 100644 lib/Test2/Harness/Runner/Resource/JobCount.pm delete mode 100644 lib/Test2/Harness/Runner/Resource/SharedJobSlots.pm delete mode 100644 lib/Test2/Harness/Runner/Resource/SharedJobSlots/Config.pm delete mode 100644 lib/Test2/Harness/Runner/Resource/SharedJobSlots/State.pm delete mode 100644 lib/Test2/Harness/Runner/Run.pm delete mode 100644 lib/Test2/Harness/Runner/Spawn.pm delete mode 100644 lib/Test2/Harness/Runner/State.pm create mode 100644 lib/Test2/Harness/Scheduler.pm create mode 100644 lib/Test2/Harness/Scheduler/Default.pm create mode 100644 lib/Test2/Harness/Scheduler/Default/Run.pm delete mode 100644 lib/Test2/Harness/Util/IPC.pm diff --git a/lib/Test2/Harness/Auditor.pm b/lib/Test2/Harness/Auditor.pm deleted file mode 100644 index c594246e5..000000000 --- a/lib/Test2/Harness/Auditor.pm +++ /dev/null @@ -1,176 +0,0 @@ -package Test2::Harness::Auditor; -use strict; -use warnings; - -our $VERSION = '1.000152'; - -use File::Spec; -use Time::HiRes qw/time/; - -use Test2::Harness::Util::UUID qw/gen_uuid/; -use Test2::Harness::Util::JSON qw/decode_json/; - -use Test2::Harness::Event; -use Test2::Harness::Auditor::Watcher; - -use Test2::Harness::Util::HashBase qw{ - {+WATCHERS} //= {}; -} - -sub process { - my $self = shift; - - while (my $line = ) { - my $data = decode_json($line); - last unless defined $data; - my $e = Test2::Harness::Event->new($data); - - # If process_event does not return anything we need to record just this - # event. If it does return then we want to record what it returns. - if (my @events = $self->process_event($e)) { - $self->{+ACTION}->($_) for @events; - } - else { - $self->{+ACTION}->($e); - } - } -} - -sub process_event { - my $self = shift; - my ($e) = @_; - - my $job_id = $e->job_id; - my $job_try = $e->job_try // 0; - - # Do nothing for non-job events - return $e unless $job_id; - - my $f = $e->facet_data; - - if (my $task = $f->{harness_job_queued}) { - $self->{+WATCHERS}->{$job_id} //= []; - $self->{+QUEUED}->{$job_id} //= $task; - return $e; - } - - my $tries = $self->{+WATCHERS}->{$job_id} or return $self->broken($e, "Never saw queue entry"); - - if (my $job = $f->{harness_job}) { - $tries->[$job_try] = Test2::Harness::Auditor::Watcher->new(job => $job, try => $job_try); - } - - my $watcher = $tries->[$job_try] or return $self->broken($e, "never saw harness_job facet"); - - return $watcher->process($e); -} - -sub broken { - my $self = shift; - my ($e, $message) = @_; - - $self->{+BROKEN}->{$e->job_id}++; - - push @{$e->facet_data->{errors} //= []} => {details => $message, fail => 1}; - - return $e; -} - -sub finish { - my $self = shift; - - my $final_data = {pass => 1}; - - while (my ($job_id, $watchers) = each %{$self->{+WATCHERS}}) { - my $file = File::Spec->abs2rel($self->{+QUEUED}->{$job_id}->{file}); - - if (@$watchers) { - push @{$final_data->{failed}} => [$job_id, $file, $watchers->[-1]->failed_subtest_tree] if $watchers->[-1]->fail; - push @{$final_data->{retried}} => [$job_id, scalar(@$watchers), $file, $watchers->[-1]->pass ? 'YES' : 'NO'] if @$watchers > 1; - - if (my $halt = $watchers->[-1]->halt) { - push @{$final_data->{halted}} => [$job_id, $file, $halt]; - } - } - else { - push @{$final_data->{unseen}} => [$job_id, $self->{+QUEUED}->{$job_id}->{file}]; - } - } - - $final_data->{pass} = 0 if $final_data->{failed} or $final_data->{unseen}; - - my $e = Test2::Harness::Event->new( - job_id => 0, - stamp => time, - event_id => gen_uuid(), - run_id => $self->{+RUN_ID}, - facet_data => {harness_final => $final_data}, - ); - - $self->{+ACTION}->($e); - $self->{+ACTION}->(undef); -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Auditor - Auditor that validates test results by processing an -event stream. - -=head1 DESCRIPTION - -The auditor is responsible for taking a stream of events and determining what -is passing or failing. An L instance is -created for every job_id seen, and events for each job are passed to the proper -watcher for state management. - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Auditor/Watcher.pm b/lib/Test2/Harness/Auditor/Watcher.pm deleted file mode 100644 index 7b730a740..000000000 --- a/lib/Test2/Harness/Auditor/Watcher.pm +++ /dev/null @@ -1,488 +0,0 @@ -package Test2::Harness::Auditor::Watcher; -use strict; -use warnings; - -our $VERSION = '1.000152'; - -use Carp qw/croak confess/; -use Scalar::Util qw/blessed/; -use List::Util qw/first max/; - -use Test2::Harness::Util::UUID qw/gen_uuid/; - -use Test2::Harness::Util qw/hub_truth parse_exit/; - -use Test2::Harness::Auditor::TimeTracker; - -use Test2::Harness::Util::HashBase qw{ - -job - -try - - -assertion_count - -exit - -plan - -_errors - -_failures - -_sub_failures - -_plans - -_info - -_sub_info - -_subtest_id - -nested - -subtests - -numbers - -times - -halt - -failed_subtest_tree -}; - -sub init { - my $self = shift; - - croak "'job' is a required attribute" - unless $self->{+JOB}; - - croak "'try' is a required attribute" - unless defined $self->{+TRY}; - - $self->{+_FAILURES} = 0; - $self->{+_ERRORS} = 0; - $self->{+ASSERTION_COUNT} = 0; - - $self->{+NUMBERS} = {}; - $self->{+TIMES} = Test2::Harness::Auditor::TimeTracker->new(); - - $self->{+NESTED} = 0 unless defined $self->{+NESTED}; -} - -sub pass { !$_[0]->fail } -sub file { $_[0]->{+JOB}->{file} } -sub fail { !!$_[0]->fail_error_facet_list } - -sub has_exit { defined $_[0]->{+EXIT} } -sub has_plan { defined $_[0]->{+PLAN} } - -sub process { - my $self = shift; - my ($event) = @_; - - my $f = $event->{facet_data}; - my $hf = hub_truth($f); - - my $nested = $hf->{nested} || 0; - - $self->times->process($event, $f, $self->{+ASSERTION_COUNT}) unless $nested; - - return if $hf->{buffered}; - - my $is_ours = $nested == $self->{+NESTED}; - - return unless $is_ours || $f->{from_tap}; - - # Add parent if we start a buffered subtest - if ($f->{harness} && $f->{harness}->{subtest_start}) { - my $st = $self->{+SUBTESTS}->{$nested + 1} ||= {}; - $st->{event} = $event; - $f->{harness_watcher}->{no_render} = 1; - return; - } - - my @out; - - # Not actually a subtest end, someone printed to STDOUT - if ($f->{from_tap} && $f->{harness}->{subtest_end} && !($self->{+SUBTESTS} && keys %{$self->{+SUBTESTS}})) { - # Alter $f so that this incorrect event is not sent to the renderer. - $f->{harness_watcher}->{no_render} = 1; - - # Make a new $f and $event for the rest of the processing. - $f = { - %{$f}, - harness_watcher => {added_by_watcher => 1}, - parent => undef, - trace => undef, - harness => { - %{$f->{harness} || {}}, - subtest_end => undef, - }, - info => [ - @{$f->{info} || []}, - { - details => $f->{from_tap}->{details}, - tag => $f->{from_tap}->{source} || 'STDOUT', - from_harness => 1, - } - ], - }; - - $event = Test2::Harness::Event->new(stamp => time, job_try => $self->{+TRY}, facet_data => $f); - } - - push @out => $event; - - # Close any deeper subtests - if (my $sts = $self->{+SUBTESTS}) { - my @close = sort { $b <=> $a } grep { $_ > $nested } keys %$sts; - - for my $n (@close) { - my $st = delete $sts->{$n}; - my $se = $st->{event} || $event; - - my $fd = $se->{facet_data}; - delete $fd->{harness_watcher}->{no_render}; - $fd->{parent}->{hid} ||= $n; - $fd->{parent}->{children} ||= $st->{children}; - $fd->{harness}->{closed_by} = $event; - $fd->{harness}->{closed_by_eid} = $event->{event_id}; - - my $pn = $n - 1; - - if ($st->{event}) { - if ($pn > $self->{+NESTED}) { - push @{$sts->{$pn}->{children}} => $fd; - } - elsif ($pn == $self->{+NESTED}) { - $self->subtest_process($fd, $se); - push @out => $se; - } - } - else { - push @out => $se if $self->{+NESTED} && $pn == $self->{+NESTED}; - } - } - } - - unless ($is_ours) { - my $st = $self->{+SUBTESTS}->{$nested} ||= {}; - my $fd = {%$f}; - push @{$st->{children}} => $fd; - return @out; - } - - $self->subtest_process($f, $event); - return @out; -} - -sub subtest_process { - my $self = shift; - my ($f, $event) = @_; - - my $closer = delete $f->{harness}->{closed_by}; - $event ||= Test2::Harness::Event->new(facet_data => $f, job_try => $self->{+TRY}); - - $self->{+NUMBERS}->{$f->{assert}->{number}}++ - if $f->{assert} && $f->{assert}->{number}; - - if ($f->{parent} && $f->{assert}) { - my $name = $f->{assert}->{details} // "unnamed subtest ($f->{trace}->{frame}->[1] line $f->{trace}->{frame}->[2])"; - - my $subwatcher = blessed($self)->new(nested => $self->{+NESTED} + 1, job => $self->{+JOB}, try => $self->{+TRY}); - - my $id = 1; - for my $sf (@{$f->{parent}->{children}}) { - $sf->{harness}->{job_id} ||= $f->{harness}->{job_id}; - $sf->{harness}->{run_id} ||= $f->{harness}->{run_id}; - $sf->{harness}->{event_id} ||= $sf->{about}->{uuid} ||= gen_uuid(); - $subwatcher->subtest_process($sf); - } - - my @errors = $subwatcher->subtest_fail_error_facet_list(); - - if ($f->{harness}->{subtest_start}) { - push @{$f->{errors}} => {tag => 'REASON', fail => 1, from_harness => 1, details => "Buffered subtest ended abruptly (missing closing brace event)"} - unless $closer && $closer->{facet_data}->{harness}->{subtest_end}; - } - - my $fail = 0; - if (@errors) { - push @{$f->{errors}} => @errors; - $fail = 1; - } - else { - $fail ||= $f->{assert} && !$f->{assert}->{pass} && !($f->{amnesty} && @{$f->{amnesty}}); - $fail ||= $f->{control} && ($f->{control}->{halt} || $f->{control}->{terminate}); - $fail ||= $f->{errors} && first { $_->{fail} } @{$f->{errors}}; - } - - if ($fail) { - $self->{+_SUB_FAILURES}++; - - # Populate the tree up to this subtest - my $tree = $self->{+FAILED_SUBTEST_TREE} //= []; - push @$tree => [$name, $subwatcher->{+FAILED_SUBTEST_TREE} // []]; - } - } - - $self->{+ASSERTION_COUNT}++ if $f->{assert}; - - if ($f->{assert} && !$f->{assert}->{pass} && !($f->{amnesty} && @{$f->{amnesty}})) { - $self->{+_FAILURES}++; - } - - if ($f->{control} || $f->{errors}) { - my $err ||= $f->{control} && ($f->{control}->{halt} || $f->{control}->{terminate}); - $err ||= $f->{errors} && first { $_->{fail} } @{$f->{errors}}; - $self->{+_ERRORS}++ if $err; - $self->{+HALT} = $f->{control}->{details} || '1' if $f->{control} && $f->{control}->{halt} && (!$self->{+HALT} || $self->{+HALT} eq '1'); - } - - if ($f->{plan} && !$f->{plan}->{none}) { - $self->{+_PLANS}++; - $self->{+PLAN} = $f->{plan}; - } - - if ($f->{harness_job_exit}) { - $self->{+EXIT} = $f->{harness_job_exit}->{exit}; - - my $file = $self->file(); - - my $end = $f->{harness_job_end} = { - file => $file, - rel_file => File::Spec->abs2rel($file), - abs_file => File::Spec->rel2abs($file), - retry => $f->{harness_job_exit}->{retry}, - fail => $self->fail(), - stamp => $f->{harness_job_exit}->{stamp}, - }; - - my $plan = $self->plan; - $end->{skip} = $plan->{details} || "No reason given" if $plan && !$plan->{count}; - - my $times = $self->times; - if ($times && $times->useful) { - $end->{times} = $times->data_dump; - push @{$f->{harness_job_fields}} => $times->job_fields; - push @{$f->{info}} => {tag => 'TIME', details => $times->summary, table => $times->table}; - } - - push @{$f->{errors}} => $self->fail_error_facet_list; - } - - return; -} - -sub subtest_fail_error_facet_list { - my $self = shift; - - return @{$self->{+_SUB_INFO}} if $self->{+_SUB_INFO}; - - my @out; - - my $plan = $self->{+PLAN} ? $self->{+PLAN}->{count} : undef; - my $count = $self->{+ASSERTION_COUNT}; - - my $numbers = $self->{+NUMBERS}; - my $max = max(keys %$numbers); - if ($max) { - for my $i (1 .. $max) { - if (!$numbers->{$i}) { - push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Assertion number $i was never seen"}; - } - elsif ($numbers->{$i} > 1) { - push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Assertion number $i was seen more than once"}; - } - } - } - - if (!$self->{+_PLANS}) { - if ($count) { - push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "No plan was declared"}; - } - else { - push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "No plan was declared, and no assertions were made."}; - } - } - elsif ($self->{+_PLANS} > 1) { - push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Too many plans were declared (Count: $self->{+_PLANS})"}; - } - - push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Planned for $plan assertions, but saw $self->{+ASSERTION_COUNT}"} - if $plan && $count != $plan; - - push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Subtest failures were encountered (Count: $self->{+_SUB_FAILURES})"} - if $self->{+_SUB_FAILURES}; - - return @out; -} - -sub fail_error_facet_list { - my $self = shift; - - return @{$self->{+_INFO}} if $self->{+_INFO}; - - my @out; - - my $incomplete_subtests = values %{$self->{+SUBTESTS}}; - push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "One or more incomplete subtests (Count: $incomplete_subtests)"} - if $incomplete_subtests; - - if (my $wstat = $self->{+EXIT}) { - if ($wstat == -1) { - push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "The harness could not get the exit code! (Code: $wstat)"}; - } - else { - my $e = parse_exit($wstat); - if ($e->{err}) { - push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Test script returned error (Err: $e->{err})"}; - } - if ($e->{sig}) { - push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Test script returned error (Signal: $e->{sig})"}; - } - } - } - - push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Errors were encountered (Count: $self->{+_ERRORS})"} - if $self->{+_ERRORS}; - - push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Assertion failures were encountered (Count: $self->{+_FAILURES})"} - if $self->{+_FAILURES}; - - push @out => $self->subtest_fail_error_facet_list(); - - return @out; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Auditor::Watcher - Class to monitor events for a single job and -pass judgement on the result. - -=head1 DESCRIPTION - -This module represents a per-job state tracker. This module sees every event -and manages the state produced. In the end this tracker determines if a test -job passed or failed, and why. - -=head1 SYNOPSIS - - use Test2::Harness::Auditor::Watcher; - - my $watcher = Test2::Harness::Auditor::Watcher->new(); - - for my $event (@events) { - $watcher->process($event); - } - - print "Pass!" if $watcher->pass; - print "Fail!" if $watcher->fail; - -=head1 METHODS - -=over 4 - -=item $int = $watcher->assertion_count() - -Number of assertions that have been seen. - -=item $exit = $watcher->exit() - -If the job has exited this will return the exit value (integer, 0 or greater). -If the job has not exited yet (or at least if the watcher has not seen the exit -event yet) this will return undef. - -=item $bool = $watcher->fail() - -Returns true if the job has failed/is failing. - -=item @error_facets = $watcher->fail_error_facet_list - -Used internally to get a list of 'error' facets to inject into the -harness_job_exit event. - -=item $file = $watcher->file - -If the test file is known this will return it (string). This will return undef -if the file is not yet known. - -=item $string = $watcher->halt - -If the test was halted (bail-out) this will contain the human readible reason. - -=item $bool = $watcher->has_exit - -Check if the exit value is known. - -=item $bool = $watcher->has_plan - -Check if a plan has been seen. - -=item $job = $watcher->job - -If the job is known this will return the detailed structure of the job. - -=item $int = $watcher->nested - -If this watcher represents a subtest this will be an integer greater than 0, -the top-level test is 0. - -=item $hash = $watcher->numbers - -This is an internal state tracking what test numbers have been seen. This is -really only applicable in tests that produced TAP. - -=item $bool = $watcher->pass - -Check if the test job is passing. - -=item $plan_facet = $watcher->plan() - -If the plan facet has been seen this will return it. - -=item $watcher->process($event); - -Modify the state based on the provided event. - -=item $watcher->subtest_fail_error_facet_list - -Used internally to get a list of 'error' facets to inject into the -harness_job_exit event. - -=item $times = $watcher->times() - -Retuns the L instance. - -=item $int = $watcher->try() - -Sometimes a job is run more than once, in those cases this will be an integer -greater than 0 representing the try. 0 is used for the first try. - -=back - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/IPC/Process.pm b/lib/Test2/Harness/IPC/Process.pm deleted file mode 100644 index d15e472be..000000000 --- a/lib/Test2/Harness/IPC/Process.pm +++ /dev/null @@ -1,134 +0,0 @@ -package Test2::Harness::IPC::Process; -use strict; -use warnings; - -our $VERSION = '1.000152'; - -use Carp qw/croak/; - -use Test2::Harness::Util::HashBase qw{ - {+CATEGORY} //= 'default' } - -sub set_pid { - my $self = shift; - my ($pid) = @_; - - croak "pid has already been set" if defined $self->{+PID}; - - $self->{+PID} = $pid; -} - -sub set_exit { - my $self = shift; - my ($ipc, $exit, $time) = @_; - - croak "exit has already been set" if defined $self->{+EXIT}; - - $self->{+EXIT} = $exit; - $self->{+EXIT_TIME} = $time; -} - -sub spawn_params { - my $self = shift; - my $class = ref($self) || $self; - - croak "Process class '$class' does not implement 'spawn_params()'"; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::IPC::Process - Base class for processes controlled by -Test2::Harness::IPC. - -=head1 DESCRIPTION - -All processes controlled by L should subclass this one. - -=head1 ATTRIBUTES - -=over 4 - -=item $int = $proc->exit - -Exit value, if set. Otherwise C. - -=item $stamp = $proc->exit_time - -Timestamp of the process exit, if set, otherwise C. - -=item $pid = $proc->pid - -Pid of the process, if it has been started. - -=item $cat = $proc->category - -Set at construction, C<'default'> if not provided. - -=back - -=head1 METHODS - -=over 4 - -=item $opt->set_pid($pid) - -Set the process id. - -=item $opt->set_exit($ipc, $exit, $time) - -Set the process as complete. $exit should be the exit value. $time should be a -timestamp. $ipc is an instance of L. - -=item $hashref = $opt->spawn_params() - -Used when spawning the process, args go to C from -L. - -The base class throws an exception if this method is called. - -=back - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Auditor/TimeTracker.pm b/lib/Test2/Harness/Log/TimeTracker.pm similarity index 97% rename from lib/Test2/Harness/Auditor/TimeTracker.pm rename to lib/Test2/Harness/Log/TimeTracker.pm index 7da18c0fa..1d6597176 100644 --- a/lib/Test2/Harness/Auditor/TimeTracker.pm +++ b/lib/Test2/Harness/Log/TimeTracker.pm @@ -1,8 +1,8 @@ -package Test2::Harness::Auditor::TimeTracker; +package Test2::Harness::Log::TimeTracker; use strict; use warnings; -our $VERSION = '1.000152'; +our $VERSION = '2.000000'; use Test2::Harness::Util qw/hub_truth/; use Test2::Util::Times qw/render_duration/; @@ -207,7 +207,7 @@ __END__ =head1 NAME -Test2::Harness::Auditor::TimeTracker - Module that tracks timing data while an +Test2::Harness::Log::TimeTracker - Module that tracks timing data while an event stream is processed. =head1 DESCRIPTION @@ -230,9 +230,9 @@ long the test took in each of several stages. =head1 SYNOPSIS - use Test2::Harness::Auditor::TimeTracker; + use Test2::Harness::Log::TimeTracker; - my $tracker = Test2::Harness::Auditor::TimeTracker->new(); + my $tracker = Test2::Harness::Log::TimeTracker->new(); my $assert_count = 0; for my $event (@events) { diff --git a/lib/Test2/Harness/Preload.pm b/lib/Test2/Harness/Preload.pm new file mode 100644 index 000000000..068cc390e --- /dev/null +++ b/lib/Test2/Harness/Preload.pm @@ -0,0 +1,520 @@ +package Test2::Harness::Preload; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp qw/croak confess/; + +use Test2::Harness::Preload::Stage(); + +sub import { + my $class = shift; + my $caller = caller; + + my %exports; + + my $instance = $class->new; + + $exports{TEST2_HARNESS_PRELOAD} = sub { $instance }; + + $exports{stage} = sub { + my ($name, $code) = @_; + my @caller = caller(); + $instance->build_stage( + name => $name, + code => $code, + caller => \@caller, + ); + }; + + $exports{eager} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->set_eager(1); + }; + + $exports{default} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + my $name = $stage->name; + $instance->set_default_stage($name); + }; + + for my $name (qw/pre_fork post_fork pre_launch/) { + my $meth = "add_${name}_callback"; + $exports{$name} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->$meth(@_); + }; + } + + $exports{watch} = sub { + if (@{$instance->stack}) { + my $stage = $instance->stack->[-1]; + return $stage->watch(@_); + } + + if ($INC{'Test2/Harness/Reloader.pm'}) { + if (my $active = Test2::Harness::Reloader->ACTIVE) { + $active->watch(@_); + } + } + + croak "No current stage, and no active reloader"; + }; + + $exports{preload} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->add_to_load_sequence(@_); + }; + + $exports{reload_remove_check} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->set_reload_remove_check(@_); + }; + + $exports{reload_inplace_check} = sub { + croak "No current stage" unless @{$instance->stack}; + my $stage = $instance->stack->[-1]; + $stage->set_reload_inplace_check(@_); + }; + + for my $name (keys %exports) { + no strict 'refs'; + *{"$caller\::$name"} = $exports{$name}; + } +} + +use Test2::Harness::Util::HashBase qw{ + {+STAGE_LIST} //= []; + $self->{+STAGE_LOOKUP} //= {}; + + $self->{+STACK} //= []; +} + +sub build_stage { + my $self = shift; + my %params = @_; + + my $caller = $params{caller} //= [caller()]; + + die "A coderef is required at $caller->[1] line $caller->[2].\n" + unless $params{code}; + + my $stage = Test2::Harness::Preload::Stage->new( + stage_lookup => $self->{+STAGE_LOOKUP}, + %params, + ); + + my $stack = $self->{+STACK} //= []; + push @$stack => $stage; + + my $ok = eval { $params{code}->($stage); 1 }; + my $err = $@; + + die "Mangled stack" unless @$stack && $stack->[-1] eq $stage; + + pop @$stack; + + die $err unless $ok; + + if (@$stack) { + $stack->[-1]->add_child($stage); + } + else { + $self->add_stage($stage, $caller); + } + + return $stage; +} + +sub add_stage { + my $self = shift; + my ($stage, $caller) = @_; + + $caller //= [caller()]; + + my @all = ($stage, @{$stage->all_children}); + + for my $item (@all) { + my $name = $item->name; + + if (my $existing = $self->{+STAGE_LOOKUP}->{$name}) { + $caller //= [caller()]; + my $ncaller = $item->frame; + my $ecaller = $existing->frame; + die <<" EOT" +A stage named '$name' was already defined. + First at $ecaller->[1] line $ecaller->[2]. + Second at $ncaller->[1] line $ncaller->[2]. + Mixed at $caller->[1] line $caller->[2]. + EOT + } + + $self->{+STAGE_LOOKUP}->{$name} = $item; + } + + push @{$self->{+STAGE_LIST}} => $stage; +} + +sub merge { + my $self = shift; + my ($merge) = @_; + + my $caller = [caller()]; + + for my $stage (@{$merge->{+STAGE_LIST}}) { + $self->add_stage($stage, $caller); + } + + $self->{+DEFAULT_STAGE} //= $merge->default_stage; +} + +sub add_file_stage { confess "deprecated, use a plugin to assign stages to tests" } +sub file_stage { confess "deprecated, use a plugin to assign stages to tests" } + +sub default_stage { + my $self = shift; + return $self->{+DEFAULT_STAGE} if $self->{+DEFAULT_STAGE}; + return $self->{+STAGE_LIST}->[0]; +} + +sub set_default_stage { + my $self = shift; + my ($name) = @_; + + croak "Default stage already set to $self->{+DEFAULT_STAGE}" if $self->{+DEFAULT_STAGE}; + $self->{+DEFAULT_STAGE} = $name; +} + +sub eager_stages { + my $self = shift; + + my %eager; + + for my $root (@{$self->{+STAGE_LIST}}) { + for my $stage ($root, @{$root->all_children}) { + next unless $stage->eager; + $eager{$stage->name} = [map { $_->name } @{$stage->all_children}]; + } + } + + return \%eager; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Preload - DSL for building complex stage-based preload +tools. + +=head1 DESCRIPTION + +L allows you to preload libraries for a performance boost. This +module provides tools that let you go beyond that and build a more complex +preload. In addition you can build multiple preload I, each stage will +be its own process and tests can run from a specific stage. This allows for +multiple different preload states from which to run tests. + +=head1 SYNOPSIS + +=head2 USING YOUR PRELOAD + +The C<-P> or C<--preload> options work for custom preload modules just as they +do regular modules. Yath will know the difference and act accordingly. + + yath test -PMy::Preload + +=head2 WRITING YOUR PRELOAD + + package My::Preload; + use strict; + use warnings; + + # This imports several useful tools, and puts the necessary meta-data in + # your package to identify it as a special preload. + use Test2::Harness::Preload; + + # You must specify at least one stage. + stage Moose => sub { + # Preload can be called multiple times, and can load multiple modules + # per call. Order is preserved. + preload 'Moose', 'Moose::Role'; + preload 'Scalar::Util', 'List::Util'; + + # preload can also be given a sub if you have some custom code to run + # at a specific point in the load order + preload sub { + # Do something before loading Try::Tiny + ... + }; + + preload 'Try::Tiny'; + + # Tell the runner to watch this file for changes, if it does change run + # the sub instead of the usual reload process. This lets you reload + # configs and other non-perl files, or allows you to use a custom + # reload sub for perl files. + watch 'path/to/file' => sub { ... }; + + # You can also use watch inside preload subs: + preload sub { + watch 'path/to/file' => sub { ... }; + }; + + # In app code you can add watches dynamically when applicable: + preload sub { + ... # inside app code + + if ($INC{'Test2/Harness/Reloader.pm'}) { + if (my $active = Test2::Harness::Reloader->ACTIVE) { + $active->watch('path/to/file' => sub { ... }); + } + } + + ... + }; + + # Eager means tests from nested stages can be run in this stage as + # well, this is useful if the nested stage takes a long time to load as + # it allows yath to start running tests sooner instead of waiting for + # the stage to finish loading. Once the nested stage is loaded tests + # intended for it will start running from it instead. + eager(); + + # default means this stage is the one to use if the test does not + # specify a stage. + default(); + + # These are hooks that let you run arbitrary code at specific points in + # the process. pre_fork happens just before forking to run a test. + # post_fork happens just after forking for a test. pre_launch happens + # as late as possible before the test starts executing (post fork, + # after $0 and other special state are reset). + pre_fork sub { ... }; + post_fork sub { ... }; + pre_launch sub { ... }; + + # Stages can be nested, nested ones build off the previous stage, but + # are in a forked process to avoid contaminating the parent. + stage Types => sub { + preload 'MooseX::Types'; + }; + }; + + # Alternative stage that loads Moo instead of Moose + stage Moo => sub { + preload 'Moo'; + + ... + }; + +=head2 HARNESS DIRECTIVES IN PRELOADS + +If you use a staged preload, and the --reload option, you can add 'CHURN' +directives to files in order to only reload sections you are working on. This +is particularly useful when a file cannot be reloaded in full, or when doing so +is expensive. You can wrap subroutines in the churn directives to have yath +reload only those subroutines. + + sub do_not_reload_this { ... { + + # HARNESS-CHURN-START + + sub reload_this_one { + ... + } + + sub reload_this_one_too { + ... + } + + # HARNESS-CHURN-STOP + + sub this_is_not_reloaded { ... } + +You can put as many churn sections you want in as many preloaded modules as you +want. If a change is detected then only the churn sections will be reloaded. +The churn sections are reloaded by taking the source between the start and stop +markers, and running them in an eval like this: + + eval < statement inside the markers. If the strict/warnings settings are not to +your specifications you can add overrides inside the markers. Any valid perl +code can go into the markers. + +B Be aware they do not have their original scope, and that can lead +to problems if you are not paying attention. Variables outside your markers are +not accessible, and lexical variables put inside your markers will be "new" on +each reload, this can cause confusion if you have lexicals used by multiple +subs where some are inside churn blocks and others are not, so best not to do +that. Package variables work a bit better, but any assignment lines are re-run. +So C is fine (it does not change the value if it is set) but +C will reset the var on each reload. + +=head1 EXPORTS + +=over 4 + +=item $meta = TEST2_HARNESS_PRELOAD() + +=item $meta = $class->TEST2_HARNESS_PRELOAD() + +This export provides the meta object, which is an instance of this class. This +method being present is how Test2::Harness differentiates between a regular +module and a special preload library. + +=item stage NAME => sub { ... } + +This creates a new stage with the given C, and then runs the coderef with +the new stage set as the I one upon which the other function here will +operate. Once the coderef returns the I stage is cleared. + +You may nest stages by calling this function again inside the codeblock. + +B stage names B case sensitive. This can be confusing when you +consider that most harness directives are all-caps. In the following case the +stage requested by the test and the stage defined in +the library are NOT the same. + +In a test file: + + # HARNESS-STAGE-FOO + +In a preload library: + + stage foo { ... } + +Harness directives are all-caps, however the user data portion need not be, +this is fine: + + # HARNESS-STAGE-foo + +However it is very easy to make the mistake of thinking it is case insensitive. +It is also easy to assume the 'foo' part of the harness directive must be all +caps. In many cases it is smart to make your stage names all-caps. + +=item preload $module_name + +=item preload @module_names + +=item preload sub { ... } + +This B be called inside a C builder coderef. + +This adds modules to the list of libraries to preload. Order is preserved. You +can also add coderefs to execute arbitrary code between module loads. + +The coderef is called with no arguments, and its return is ignored. + +=item eager() + +This B be called inside a C builder coderef. + +This marks the I stage as being I. An eager stage will start +running tests for nested stages if it finds itself with no tests of its own to +run before the nested stage can finish loading. The idea here is to avoid +unused test slots when possible allowing for tests to complete sooner. + +=item default() + +This B be called inside a C builder coderef. + +This B be called only once across C stages in a given library. + +If multiple preload libraries are loaded then the I default set (based +on load order) will be the default, others will notbe honored. + +=item pre_fork sub { ... } + +This B be called inside a C builder coderef. + +Add a callback to be run just before the preload-stage process forks to run the +test. Note that any state changes here can effect future tests to be run. + +=item post_fork sub { ... } + +This B be called inside a C builder coderef. + +Add a callback to be run just after the preload-stage process forks to run the +test. This is run as early as possible, things like C<$0> may not be set +properly yet. + +=item pre_launch sub { ... } + +This B be called inside a C builder coderef. + +Add a callback to be run just before control of the test process is turned over +to the test file itself. This is run as late as possible, so things like C<$0> +should be set properly. + +=back + +=head1 META-OBJECT + +This class is also the meta-object used to construct a preload library. The +methods are left undocumented as this is an implementation detail and you are +not intended to directly use this object. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum Eexodist7@gmail.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/lib/Test2/Harness/Preload/Stage.pm b/lib/Test2/Harness/Preload/Stage.pm new file mode 100644 index 000000000..e17e653d4 --- /dev/null +++ b/lib/Test2/Harness/Preload/Stage.pm @@ -0,0 +1,164 @@ +package Test2::Harness::Preload::Stage; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp qw/croak/; +use Test2::Harness::Util qw/clean_path/; + +use Test2::Harness::Util::HashBase qw{ + {+FRAME} //= [caller(1)]; + + croak "'name' is a required attribute" unless $self->{+NAME}; + + croak "Stage name 'base' is reserved, pick another name" if $self->{+NAME} eq 'base'; + croak "Stage name 'NOPRELOAD' is reserved, pick another name" if $self->{+NAME} eq 'NOPRELOAD'; + + $self->{+CHILDREN} //= []; + + $self->{+PRE_FORK_CALLBACKS} //= []; + $self->{+POST_FORK_CALLBACKS} //= []; + $self->{+PRE_LAUNCH_CALLBACKS} //= []; + + $self->{+LOAD_SEQUENCE} //= []; + $self->{+WATCHES} //= {}; +} + +sub watch { + my $self = shift; + my ($file, $callback) = @_; + croak "The first argument must be a file" unless $file && -f $file; + + croak "The callback argument is required" unless $callback && ref($callback) eq 'CODE'; + + $file = clean_path($file); + + croak "There is already a watch on file '$file'" if $self->{+WATCHES}->{$file}; + + $self->{+WATCHES}->{$file} = $callback; + return; +} + +sub all_children { + my $self = shift; + + my @out = @{$self->{+CHILDREN}}; + + for (my $i = 0; $i < @out; $i++) { + my $it = $out[$i]; + push @out => @{$it->children}; + } + + return \@out; +} + +sub add_child { + my $self = shift; + my ($stage) = @_; + push @{$self->{+CHILDREN}} => $stage; +} + +sub add_pre_fork_callback { + my $self = shift; + my ($cb) = @_; + croak "Callback must be a coderef" unless ref($cb) eq 'CODE'; + push @{$self->{+PRE_FORK_CALLBACKS}} => $cb; +} + +sub add_post_fork_callback { + my $self = shift; + my ($cb) = @_; + croak "Callback must be a coderef" unless ref($cb) eq 'CODE'; + push @{$self->{+POST_FORK_CALLBACKS}} => $cb; +} + +sub add_pre_launch_callback { + my $self = shift; + my ($cb) = @_; + croak "Callback must be a coderef" unless ref($cb) eq 'CODE'; + push @{$self->{+PRE_LAUNCH_CALLBACKS}} => $cb; +} + +sub add_to_load_sequence { + my $self = shift; + + for my $item (@_) { + croak "Item '$item' is not a valid preload, must be a module name (scalar) or a coderef" + unless ref($item) eq 'CODE' || !ref($item); + + push @{$self->{+LOAD_SEQUENCE}} => $item; + } + + return @_; +} + +sub do_pre_fork { my $self = shift; $_->(@_) for @{$self->{+PRE_FORK_CALLBACKS}} } +sub do_post_fork { my $self = shift; $_->(@_) for @{$self->{+POST_FORK_CALLBACKS}} } +sub do_pre_launch { my $self = shift; $_->(@_) for @{$self->{+PRE_LAUNCH_CALLBACKS}} } + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Preload::Stage - Abstraction of a preload stage. + +=head1 DESCRIPTION + +This is an implementation detail. You are not intended to directly use/modify +instances of this class. See L for +documentation on how to write a custom preload library. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum Eexodist7@gmail.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/lib/Test2/Harness/Runner/Reloader.pm b/lib/Test2/Harness/Reloader.pm similarity index 54% rename from lib/Test2/Harness/Runner/Reloader.pm rename to lib/Test2/Harness/Reloader.pm index 010a30727..09c2638f1 100644 --- a/lib/Test2/Harness/Runner/Reloader.pm +++ b/lib/Test2/Harness/Reloader.pm @@ -1,35 +1,279 @@ -package Test2::Harness::Runner::Reloader; +package Test2::Harness::Reloader; use strict; use warnings; -our $VERSION = '1.000152'; - use Carp qw/croak/; -use Time::HiRes qw/time/; -use Test2::Harness::Util qw/file2mod is_same_file/; +use Scalar::Util qw/weaken/; + +use Test2::Harness::Util qw/clean_path file2mod/; +use Test2::Harness::Util::JSON qw/encode_json encode_pretty_json/; -use File::Spec(); +our $VERSION = '2.000000'; BEGIN { local $@; my $inotify = eval { require Linux::Inotify2; 1 }; if ($inotify) { - my $MASK = Linux::Inotify2::IN_MODIFY(); - $MASK |= Linux::Inotify2::IN_ATTRIB(); - $MASK |= Linux::Inotify2::IN_DELETE_SELF(); - $MASK |= Linux::Inotify2::IN_MOVE_SELF(); - $MASK |= Linux::Inotify2::IN_MOVE_SELF(); - *USE_INOTIFY = sub() { 1 }; - require constant; - constant->import(INOTIFY_MASK => $MASK); } else { *USE_INOTIFY = sub() { 0 }; - *INOTIFY_MASK = sub() { 0 }; } } +use Test2::Harness::Util::HashBase qw{ + $class; + + goto &$oldnew; + }; +} + +sub init { + my $self = shift; + + $self->{+RESTRICT} //= []; + + my $stage = delete $self->{+STAGE}; + if (ref $stage) { + $self->{+STAGE} = $stage; + $self->{+STAGE_NAME} = $stage->name; + } + else { + $self->{+STAGE_NAME} = $stage; + } + + $self->{+STAGE_NAME} //= $ENV{T2_HARNESS_STAGE} // "Unknown stage"; +} + +sub start { croak "$_[0] does not implement 'start'" } +sub stop { croak "$_[0] does not implement 'stop'" } +sub watch { croak "$_[0] does not implement 'watch'" } +sub changed_files { croak "$_[0] does not implement 'changed_files'" } + +sub file_has_callback { undef } + +sub find_files_to_watch { + my $self = shift; + + my %watches; + if (my $stage = $self->stage) { + %watches = %{$stage->watches}; + } + + for my $file (map { clean_path($_) } values %INC) { + next unless $self->should_watch($file); + $watches{$file} //= 1; + } + + return \%watches; +} + +sub set_active { + my $self = shift; + + return if $ACTIVE && $ACTIVE == $self; + + croak "There is already an active reloader" if $ACTIVE; + + $ACTIVE = $self; + weaken($ACTIVE); +} + +sub should_watch { + my $self = shift; + my ($file) = @_; + + my $restrict = $self->{+RESTRICT} or return 1; + return 1 unless @$restrict; + + for my $dir (@$restrict) { + return 1 if 0 == index($file, $dir); + } + + return 0; +} + +sub check_reload { + my $self = shift; + + my $changed = $self->changed_files or return 0; + return 0 unless @$changed; + + my @to_reload; + + for my $file (@$changed) { + # Force a restart + my ($status, %fields) = $self->can_reload_file($file); + unless ($status) { + $fields{reason} //= "No reason given"; + print STDERR "Cannot reload file '$file' in place: $fields{reason}\n Restarting Stage '$self->{+STAGE_NAME}'...\n"; + return 1; + } + + push @to_reload => $file; + } + + for my $file (@to_reload) { + my ($status, %fields); + unless(eval { ($status, %fields) = $self->reload_file($file); 1 }) { + %fields = (reason => $@); + $status = 0; + } + + unless ($status) { + $fields{reason} //= "No reason given"; + print STDERR "Cannot reload file '$file' in place: $fields{reason}\n Restarting Stage '$self->{+STAGE_NAME}'...\n"; + return 1; + } + } + + return 0; +} + +sub file_info { + my $self = shift; + my ($file) = @_; + + $file = clean_path($file); + + return $self->{+FILE_INFO}->{$file} if $self->{+FILE_INFO}->{$file}; + + my $info = {file => $file}; + + warn "TODO: Check for churn"; + warn "TODO: Check for stage in-place check"; + + $info->{callback} = $self->file_has_callback($file); + + if ($file =~ m/\.(pl|pm|t)$/i) { + $info->{perl} = 1; + + my %lookup; + for my $short (keys %INC) { + my $long = $INC{$short}; + $lookup{clean_path($long)} = $short; + } + + if (my $modfile = $lookup{$file}) { + my $mod = file2mod($modfile); + $info->{module} = $mod; + $info->{inc_entry} = $modfile; + + $info->{has_import} = $mod->can('import'); + $info->{t2_preload} = $mod->can('TEST2_HARNESS_PRELOAD'); + } + } + else { + $info->{perl} = 0; + } + + return $self->{+FILE_INFO}->{$file} = $info; +} + +sub can_reload_file { + my $self = shift; + my ($file) = @_; + + my $info = $self->file_info($file); + + return (1) if $info->{callback}; + + return (0, reason => "$file is not a perl module, and no callback was provided for reloading it") unless $info->{perl}; + + my $mod = $info->{module} or return (0, reason => "Unable to find the package associated with file '$file'"); + + return (0, reason => "Module $mod is a yath preload module") if $info->{t2_preload}; + return (0, reason => "Module $mod has an import() method") if $info->{has_import}; + + return (1); +} + +sub reload_file { + my $self = shift; + my ($file) = @_; + + warn "TODO: check plugin/preload callbacks"; + + if (my $cb = $self->file_has_callback($file)) { + my ($status, %fields) = $cb->($file); + return ($status, %fields) if defined $status; + } + + return $self->do_reload($file); +} + +sub do_reload { + my $self = shift; + my ($file) = @_; + + my $info = $self->file_info($file); + my $mod = $info->{module}; + + warn "Get delete symbol callback"; + + my @warnings; + my $ok = eval { + local $SIG{__WARN__} = sub { push @warnings => @_ }; + + if ($mod) { + my $stash = do { no strict 'refs'; \%{"${mod}\::"} }; + for my $sym (keys %$stash) { + next if $sym =~ m/::$/; + + # FIXME + #next if $del_cb && $del_cb->(%params, symbol => $sym, stash => $stash); + + delete $stash->{$sym}; + } + } + + delete $INC{$info->{inc_entry}}; + local $.; + require $file; + + 1; + }; + my $err = $@; + + return (0, reason => $err) unless $ok; + return (0, reason => "Got warnings: " . encode_pretty_json(\@warnings)) if @warnings; + return (1); +} + +1; + +__END__ + + + +__END__ + use Test2::Harness::Util::HashBase qw{ SUPER::init(); +} + +sub start { + my $self = shift; + + my $watcher = Linux::Inotify2->new; + $watcher->blocking(0); + $self->{+WATCHER} = $watcher; + + my $watches = $self->find_files_to_watch; + $self->{+WATCHES} = $watches; + + for my $file (keys %$watches) { + $watcher->watch($file, $MASK); + } +} + +sub stop { + my $self = shift; + delete $self->{+WATCHER}; + delete $self->{+WATCHES}; + return; +} + +sub watch { + my $self = shift; + my ($file, $cb) = @_; + + my $watcher = $self->{+WATCHER} // croak "Reloader is not started yet"; + my $watches = $self->{+WATCHES} // croak "Reloader has no watches"; + + croak "The first argument must be a file" unless $file && -f $file; + $file = clean_path($file); + + $watcher->watch($file, $MASK) unless $watches->{$file}; + + if ($cb) { + $watches->{$file} = $cb; + } + else { + $watches->{$file} ||= 1; + } +} + +sub file_has_callback { + my $self = shift; + my ($file) = @_; + + my $watches = $self->{+WATCHES} // croak "Reloader has no watches"; + + my $cb = $watches->{$file} or return undef; + my $ref = ref($cb) or return undef; + return $cb if $ref eq 'CODE'; + return undef; +} + +sub changed_files { + my $self = shift; + + my $watcher = $self->{+WATCHER} // croak "Reloader is not started yet"; + + my @todo = $watcher->read or return; + + my @out; + my %seen; + for my $item (@todo) { + my $file = $item->fullname(); + next if $seen{$file}++; + push @out => $file; + + # Make sure watcher keeps a lookout + $watcher->watch($file, $MASK); + } + + return \@out; +} + +1; diff --git a/lib/Test2/Harness/Reloader/Stat.pm b/lib/Test2/Harness/Reloader/Stat.pm new file mode 100644 index 000000000..34722d55d --- /dev/null +++ b/lib/Test2/Harness/Reloader/Stat.pm @@ -0,0 +1,111 @@ +package Test2::Harness::Reloader::Stat; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp qw/croak/; +use Time::HiRes qw/stat time/; + +use Test2::Harness::Util qw/clean_path/; + +use parent 'Test2::Harness::Reloader'; +use Test2::Harness::Util::HashBase qw{ + SUPER::init(); +} + +sub start { + my $self = shift; + + my $to_watch = $self->find_files_to_watch; + + my %watches; + for my $f (keys %$to_watch) { + my $file = clean_path($f); + + my $cb = $to_watch->{$f}; + $cb = ref($cb) ? $cb : undef; + + my $times = $self->_get_file_times($file); + + $watches{$file} = {callback => $cb, times => $times}; + } + + $self->{+WATCHES} = \%watches; +} + +sub _get_file_times { + my $self = shift; + my ($file) = @_; + my (undef, undef, undef, undef, undef, undef, undef, undef, undef, $mtime, $ctime) = stat($file); + return [$mtime, $ctime]; +} + +sub stop { + my $self = shift; + delete $self->{+WATCHES}; + return; +} + +sub watch { + my $self = shift; + my ($file, $cb) = @_; + + my $watches = $self->{+WATCHES} // croak "Reloader has no watches"; + + croak "The first argument must be a file" unless $file && -f $file; + $file = clean_path($file); + + my $watch = $watches->{$file} //= {times => $self->_get_file_times($file)}; + $watch->{callback} = $cb; + + return; +} + +sub file_has_callback { + my $self = shift; + my ($file) = @_; + + my $watches = $self->{+WATCHES} // croak "Reloader has no watches"; + + my $watch = $watches->{$file} or return undef; + return $watches->{callback}; +} + +sub changed_files { + my $self = shift; + + my $time = time; + my $last = $self->{+LAST_CHECK_STAMP} // 0; + my $delta = $time - $last; + + return if $delta < 1; + $self->{+LAST_CHECK_STAMP} = $time; + + my $watches = $self->{+WATCHES} // croak "Reloader is not started yet"; + + my @out; + for my $file (keys %$watches) { + my $watch = $watches->{$file}; + my $new_times = $self->_get_file_times($file); + my $old_times = $watch->{times} //= $new_times; + + next if $old_times->[0] == $new_times->[0] && $old_times->[1] == $new_times->[1]; + + # Update so we do not reload twice for the same change + $watch->{times} = $new_times; + + push @out => $file; + } + + return \@out; +} + +1; diff --git a/lib/Test2/Harness/Run.pm b/lib/Test2/Harness/Run.pm index 06b13075d..21f698db6 100644 --- a/lib/Test2/Harness/Run.pm +++ b/lib/Test2/Harness/Run.pm @@ -2,181 +2,118 @@ package Test2::Harness::Run; use strict; use warnings; -our $VERSION = '1.000152'; +use Carp qw/croak confess/; +use Scalar::Util qw/blessed/; -use Carp qw/croak/; +use Test2::Harness::TestSettings; +use Test2::Harness::IPC::Protocol; -use File::Spec; +use Test2::Harness::Util qw/mod2file/; -use Test2::Harness::Util::HashBase qw{ - {+RUN_ID}; - {+TEST_SETTINGS} or croak "'test_settings' is a required attribute"; + unless (blessed($ts)) { + my $class = delete $ts->{class} // 'Test2::Harness::TestSettings'; + $self->{+TEST_SETTINGS} = $class->new(%$ts); + } - {+JOBS}) { + my (@jobs, %jobs); + for my $job (@$jobs) { + my $class = $job->{job_class} // 'Test2::Harness::Run::Job'; + require(mod2file($class)); + my $jo = $class->new(%$job); + push @jobs => $jo; + $jobs{$jo->job_id} = $jo; + } + $self->{+JOBS} = \@jobs; + $self->{+JOB_LOOKUP} = \%jobs; + } - {+AGGREGATOR_IPC}; +} -sub init { +sub set_ipc { $_[0]->{+IPC} = $_[1] } +sub ipc { my $self = shift; + return $self->{+IPC} if $self->{+IPC}; - croak "run_id is required" - unless $self->{+RUN_ID}; + my $agg_ipc = $self->{+AGGREGATOR_IPC}; + return $self->{+IPC} = Test2::Harness::IPC::Protocol->new(protocol => $agg_ipc->{protocol}); } -sub run_dir { +sub set_connect { $_[0]->{+CONNECT} = $_[1] } +sub connect { my $self = shift; - my ($workdir) = @_; - return File::Spec->catfile($workdir, $self->{+RUN_ID}); -} + return $self->{+CONNECT} if $self->{+CONNECT}; -sub TO_JSON { +{ %{$_[0]} } } + my $agg_ipc = $self->{+AGGREGATOR_IPC}; + return $self->{+CONNECT} = $self->ipc->connect(@{$agg_ipc->{connect}}); +} -sub queue_item { +sub data_no_jobs { my $self = shift; - my ($plugins) = @_; - croak "a plugins arrayref is required" unless $plugins; + my %data = %$self; + delete $data{$_} for $self->no_json, 'jobs'; - my $out = {%$self}; - - my $meta = $out->{+META} //= {}; - my $fields = $out->{+FIELDS} //= []; - for my $p (@$plugins) { - $p->inject_run_data(meta => $meta, fields => $fields, run => $self); - } - - return $out; + return \%data; } -1; - -__END__ - - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Run - Representation of a set of tests to run, and their -options. - -=head1 DESCRIPTION - -=head1 ATTRIBUTES - -These are set at construction time and cannot be modified. - -See L for more documentation on these. - -=head2 FROM OPTIONS - -=over 4 - -=item $bool = $run->author_testing - -=item $hashref = $run->env_vars - -=item $bool = $run->event_uuids - -=item $arrayref = $run->fields - -=item $string = $run->input - -=item $path = $run->input_file - -=item $bool = $run->io_events - -=item $arrayref = $run->links - -=item $arrayref = $run->load - -=item $hashref = $run->load_import - -=item $bool = $run->mem_usage - -=item $int = $run->retry - -=item $bool = $run->retry_isolated - -=item $string = $run->run_id - -=item $arrayref = $run->test_args - -=item $bool = $run->unsafe_inc - -=item $bool = $run->use_stream - -=back - -=head2 OTHER - -=over 4 - -=item $hashref = $run->meta - -meta-data plugins may have attached. - -=back - -=head1 METHODS - -=over 4 - -=item $path = $run->run_dir($workdir) - -Returns the path C<"$workdir/$run_id">. - -=item $hashref = $run->queue_item(\@PLUGINS) - -Gets the queue item that represents this object. - -=back - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. +sub TO_JSON { + my $self = shift; -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. + my %data = %$self; + delete $data{$_} for $self->no_json; -See F + return \%data; +} -=cut +1; diff --git a/lib/Test2/Harness/Run/Auditor.pm b/lib/Test2/Harness/Run/Auditor.pm new file mode 100644 index 000000000..b8b49e3ff --- /dev/null +++ b/lib/Test2/Harness/Run/Auditor.pm @@ -0,0 +1,288 @@ +package Test2::Harness::Run::Auditor; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Time::HiRes qw/time/; +use List::Util qw/min max sum0/; + +use Test2::Harness::Util::HashBase qw{ + {+LAUNCHES} = 0; + $self->{+ASSERTS} = 0; + + $self->{+TIMES} //= [0, 0, 0, 0]; + + $self->{+JOBS} = {}; +} + +sub subtest_name { + my $self = shift; + my ($f) = @_; + return $f->{assert}->{details} // ($f->{trace}->{frame}->[1] . ' line ' . $f->{trace}->{frame}->[2]); +} + +sub list_nested_subtests { + my $self = shift; + my ($f) = @_; + + my $name = $self->subtest_name($f); + my @children = map { "$name -> $_" } map { $self->list_nested_subtests($_) } grep { $_->{assert} && $_->{parent} } @{$f->{parent}->{children} // []}; + + return ($name, @children); +} + +sub audit { + my $self = shift; + my ($e) = @_; + + $self->{+START} = $self->{+START} ? min($self->{+START}, $e->stamp) : $e->stamp; + $self->{+STOP} = $self->{+STOP} ? max($self->{+STOP}, $e->stamp) : $e->stamp; + + my $f = $e->facet_data; + my $job_id = $f->{harness}->{job_id} or return; + + my $jobs = $self->{+JOBS}; + + if ($f->{assert}) { + $self->{+ASSERTS}++; + } + + if ($f->{parent} && !$f->{assert}->{pass}) { + push @{$jobs->{$job_id}->{failed_subtests} //= []} => $self->list_nested_subtests($f); + } + + if (my $j = $f->{harness_job}) { + my $file = $j->{file}; + $jobs->{$job_id}->{file} = $file; + } + + if ($f->{harness_job_launch}) { + $jobs->{$job_id}->{launched}++; + $self->{+LAUNCHES}++; + } + + if (my $end = $f->{harness_job_end}) { + $jobs->{$job_id}->{end}++; + push @{$jobs->{$job_id}->{results} //= []} => $end->{fail} ? 0 : 1; + } + + if (my $x = $f->{harness_job_exit}) { + push @{$jobs->{$job_id}->{exits} //= []} => $x->{exit}; + + if (my $times = $x->{times}) { + for my $i (0 .. 3) { + $self->{+TIMES}->[$i] += $times->[$i]; + } + } + } + + if (my $c = $f->{control}) { + if ($c->{halt}) { + $jobs->{$job_id}->{halt} = $c->{details} || 'halt'; + } + } +} + +sub exit_value { + my $self = shift; + + my $final = $self->final_data; + + my $count = @{$final->{failed} // []}; + + $count = 255 if $count > 255; + return $count; +} + +sub final_data { + my $self = shift; + + return $self->{+FINAL_DATA} if $self->{+FINAL_DATA}; + + my $jobs = $self->{+JOBS}; + + my $out = {}; + + my $passing = 1; + for my $job_id (keys %$jobs) { + my $job = $jobs->{$job_id}; + + if ($job->{halt}) { + $passing = 0; + push @{$out->{halted}} => [$job_id, $job->{file}, $job->{halt}]; + } + + my $count = @{$job->{results} // []}; + + if ($count < 1) { + $passing = 0; + push @{$out->{unseen}} => [$job_id, $job->{file}]; + next; + } + + my $pass = $job->{results}->[-1]; + + if ($count > 1) { + push @{$out->{retried}} => [$job_id, $count, $job->{file}, $pass ? 'YES' : 'NO']; + } + + if (!$pass) { + $passing = 0; + push @{$out->{failed}} => [$job_id, $job->{file}, $job->{failed_subtests} ? $job->{failed_subtests} : ()]; + } + } + + $out->{pass} = $passing; + + return $self->{+FINAL_DATA} = $out; +} + +sub summary { + my $self = shift; + + return $self->{+SUMMARY} if $self->{+SUMMARY}; + + my $final_data = $self->final_data; + + my $times = $self->{+TIMES}; + my $wall = ($self->{+STOP} // 0) - ($self->{+START} // 0); + my $cpu = sum0(@$times); + + return $self->{+SUMMARY} = { + pass => $self->{+ASSERTS} ? $final_data->{pass} : 0, + cpu_usage => $wall ? int($cpu / $wall * 100) : 0, + failures => (0 + @{$final_data->{failed} // []}), + tests_seen => $self->{+LAUNCHES}, + asserts_seen => $self->{+ASSERTS}, + + time_data => { + start => $self->{+START}, + stop => $self->{+STOP}, + wall => $wall, + user => $times->[0], + system => $times->[1], + cuser => $times->[2], + csystem => $times->[3], + cpu => $cpu, + }, + }; +} + +1; + +__END__ + +sub render_summary { + my $self = shift; + my ($summary) = @_; + + my $pass = $summary->{pass}; + my $time_data = $summary->{time_data}; + my $cpu_usage = $summary->{cpu_usage}; + my $failures = $summary->{failures}; + my $tests_seen = $summary->{tests_seen}; + my $asserts_seen = $summary->{asserts_seen}; + + return if $self->quiet > 1; + + my @summary = ( + $failures ? (" Fail Count: $failures") : (), + " File Count: $tests_seen", + "Assertion Count: $asserts_seen", + $time_data + ? ( + sprintf(" Wall Time: %.2f seconds", $time_data->{wall}), + sprintf(" CPU Time: %.2f seconds (usr: %.2fs | sys: %.2fs | cusr: %.2fs | csys: %.2fs)", @{$time_data}{qw/cpu user system cuser csystem/}), + sprintf(" CPU Usage: %i%%", $cpu_usage), + ) + : (), + ); + + my $res = " --> Result: " . ($pass ? 'PASSED' : 'FAILED') . " <--"; + if ($self->color && USE_COLOR) { + require Term::ANSIColor; + my $color = $pass ? Term::ANSIColor::color('bold bright_green') : Term::ANSIColor::color('bold bright_red'); + my $reset = Term::ANSIColor::color('reset'); + $res = "$color$res$reset"; + } + push @summary => $res; + + my $msg = "Yath Result Summary"; + my $length = max map { length($_) } @summary; + my $prefix = ($length - length($msg)) / 2; + + print "\n"; + print " " x $prefix; + print "$msg\n"; + print "-" x $length; + print "\n"; + print join "\n" => @summary; + print "\n"; +} + + + + + + + { + # Was the test run a success, or were there failures? + pass => $BOOL, + + # What tests failed? + failed => [ + [ + $job_id, # Job id of the job that failed + $file, # Test filename + ], + ... + ], + + # What tests had to be retried, and did they eventually pass? + retried => [ + [ + $job_id, # Job id of the job that was retied + $tries, # Number of tries attempted + $file, # Test filename + $eventually_passed, # 'YES' if it eventually passed, 'NO' if no try ever passed. + ], + ... + ], + + # What tests sent a halt event (such as bail-out, or skip the rest) + halted => [ + [ + $job_id, # Job id of the test + $file, # Test filename + $halt, # Halt code + ], + ... + ], + + # What tests were never run (maybe because of a bail-out, or an internal error) + unseen => [ + [ + $job_id, # Job id of the test + $file, # Test filename + ], + ... + ], + } + +1; diff --git a/lib/Test2/Harness/Run/Job.pm b/lib/Test2/Harness/Run/Job.pm new file mode 100644 index 000000000..97ea0b3d6 --- /dev/null +++ b/lib/Test2/Harness/Run/Job.pm @@ -0,0 +1,92 @@ +package Test2::Harness::Run::Job; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp qw/croak/; +use Scalar::Util qw/blessed/; + +use Test2::Harness::TestFile; + +use Test2::Harness::Util::UUID qw/gen_uuid/; + +use Test2::Harness::Util::HashBase qw{ + {+JOB_ID} //= gen_uuid(); + + my $tf = $self->{+TEST_FILE} or croak "'test_file' is a required field"; + + $self->{+RESULTS} //= []; + + $self->{+TEST_FILE} = Test2::Harness::TestFile->new($tf) + unless blessed($tf); +} + +sub try { + my $self = shift; + return scalar(@{$self->{+RESULTS}}); +} + +sub launch_command { + my $self = shift; + my ($run, $ts) = @_; + + my @includes = map { "-I$_" } @{$ts->includes}; + my @loads = map { "-m$_" } @{$ts->load}; + + my $load_import = $ts->load_import; + my @imports; + for my $mod (@{$load_import->{'@'} // []}) { + my $args = $load_import->{$mod} // []; + + if ($args && @$args) { + push @imports => "-M$mod=" . join(',' => @$args); + } + else { + push @imports => "-M$mod"; + } + } + + return [ + $^X, + @{$ts->switches // []}, + @includes, + @imports, + @loads, + $self->test_file->file, + @{$ts->args // []}, + ]; +} + +sub TO_JSON { + my $self = shift; + my $class = blessed($self); + + return { + %$self, + job_class => $class, + }; +} + +sub process_info { + my $self = shift; + + my $out = $self->TO_JSON; + + delete $out->{+TEST_FILE}; + delete $out->{+RESULTS}; + + delete $out->{$_} for grep { m/^_/ } keys %$out; + + return $out; +} + +1; diff --git a/lib/Test2/Harness/Runner.pm b/lib/Test2/Harness/Runner.pm index 2fbd4b63f..a42a750c0 100644 --- a/lib/Test2/Harness/Runner.pm +++ b/lib/Test2/Harness/Runner.pm @@ -2,694 +2,112 @@ package Test2::Harness::Runner; use strict; use warnings; -our $VERSION = '1.000152'; +our $VERSION = '2.000000'; -use File::Spec(); +use Carp qw/croak/; +use Scalar::Util qw/blessed/; -use Carp qw/confess croak/; -use Fcntl qw/LOCK_EX LOCK_UN/; -use POSIX qw/:sys_wait_h/; -use Long::Jump qw/setjump longjump/; -use Time::HiRes qw/sleep time/; -use Scope::Guard; +use Test2::Harness::Util qw/parse_exit/; +use Test2::Harness::IPC::Util qw/start_process/; +use Test2::Harness::Util::JSON qw/encode_json/; -use Test2::Harness::Util qw/clean_path file2mod mod2file open_file parse_exit write_file_atomic process_includes chmod_tmp write_file/; -use Test2::Harness::Util::Queue(); -use Test2::Harness::Util::JSON(qw/encode_json/); +use Test2::Harness::TestSettings; -use Test2::Harness::Runner::Constants; +use Test2::Harness::Util::HashBase qw{ + {+ROOTPID} = $$; - $RUNNER_PID = $$; - - croak "'dir' is a required attribute" unless $self->{+DIR}; - croak "'settings' is a required attribute" unless $self->{+SETTINGS}; - - my $dir = clean_path($self->{+DIR}); - - croak "'$dir' is not a valid directory" - unless -d $dir; + croak "'workdir' is a required attribute" unless $self->{+WORKDIR}; - $self->{+DIR} = $dir; - - $self->{+HANDLERS}->{HUP} = sub { - my $sig = shift; - print "$$ $0 ($self->{+STAGE}) Runner caught SIG$sig, reloading...\n"; - $self->{+SIGNAL} = $sig; - }; - - my $tmp_dir = File::Spec->catdir($self->{+DIR}, 'tmp'); - unless (-d $tmp_dir) { - mkdir($tmp_dir) or die "Could not create temp dir: $!"; - chmod_tmp($tmp_dir); - } - $self->{+TMP_DIR} = $tmp_dir; - - my $have_job_limiter = 0; - for my $res (@{$self->{+RESOURCES}}) { - require(mod2file($res)) unless ref($res); - $have_job_limiter++ if $res->job_limiter; - } - - unless ($have_job_limiter) { - require Test2::Harness::Runner::Resource::JobCount; - unshift @{$self->{+RESOURCES}} => 'Test2::Harness::Runner::Resource::JobCount'; + my $ts = $self->{+TEST_SETTINGS} or croak "'test_settings' is a required attribute"; + unless (blessed($ts)) { + my $class = delete $ts->{class} // 'Test2::Harness::TestSettings'; + $self->{+TEST_SETTINGS} = $class->new(%$ts); } - - $self->SUPER::init(); -} - -sub preloader { - my $self = shift; - - $self->{+PRELOADER} //= Test2::Harness::Runner::Preloader->new( - dir => $self->{+DIR}, - preloads => $self->preloads, - monitor => $self->{+MONITOR_PRELOADS}, - restrict_reload => $self->{+RESTRICT_RELOAD}, - dump_depmap => $self->{+DUMP_DEPMAP}, - reload => $self->{+RELOAD}, - - below_threshold => ($self->{+PRELOAD_THRESHOLD} && $self->{+JOBS_TODO} && $self->{+PRELOAD_THRESHOLD} > $self->{+JOBS_TODO}) ? 1 : 0, - ); } -sub state { - my $self = shift; - - my $preloader = $self->preloader; - - my $settings = $self->settings; - $self->{+STATE} //= Test2::Harness::Runner::State->new( - workdir => $self->{+DIR}, - eager_stages => $preloader->eager_stages // {}, - preloader => $preloader, - resources => [map { $_->new(settings => $settings) } @{$self->{+RESOURCES}}], - settings => $settings, - ); -} - -sub check_timeouts { - my $self = shift; - - return unless $self->settings->runner->use_timeout; - - my $now = time; - - # Check only once per second, that is as granular as we get. Also the check is not cheep. - return if $self->{+LAST_TIMEOUT_CHECK} && $now < (1 + $self->{+LAST_TIMEOUT_CHECK}); - - for my $pid (keys %{$self->{+PROCS}}) { - my $job = $self->{+PROCS}->{$pid}; - next unless $job->isa('Test2::Harness::Runner::Job'); - next unless $job->use_timeout; - - my $et = $job->event_timeout // $self->{+EVENT_TIMEOUT}; - my $pet = $job->post_exit_timeout // $self->{+POST_EXIT_TIMEOUT}; - - next unless $et || $pet; - - my $changed = $job->output_changed(); - my $delta = $now - $changed; - - # Event timout if we are checking for one, and if the delta is larger than the timeout. - my $e_to = $et && $delta > $et; +sub stages { ['NONE'] } +sub stage_sets { [['NONE', 'NONE']] } - # Post-Exit timeout if we are checking for one, the process has exited (we are waiting) and the delta is larger than the timeout. - my $pe_to = $pet && $self->{+WAITING}->{$pid} && $delta > $pet; +sub job_stage { 'NONE' } - next unless $e_to || $pe_to; +sub start { } - my $kill = -f $job->et_file || -f $job->pet_file; +sub abort {} +sub kill {} - write_file_atomic($job->et_file, "$now $delta") if $e_to && !-f $job->et_file; - write_file_atomic($job->pet_file, "$now $delta") if $pe_to && !-f $job->pet_file; +sub job_update { } - my $sigmap = $self->SIG_MAP; - my $sig = $kill ? $sigmap->{'KILL'} : $sigmap->{'TERM'}; - - $sig = "-$sig" if $self->USE_P_GROUPS; - - print STDERR "$$ $0 " . $job->file . " did not respond to SIGTERM, sending SIGKILL to $pid...\n" if $kill; - - # storing the jobid we had to stop - $self->{run_reached_timeout} //= {}; - $self->{run_reached_timeout}->{$job->task->{job_id}} = $pid; - - kill($sig, $pid); - } - - $self->{+LAST_TIMEOUT_CHECK} = time; -} - -sub stop { +sub job_launch_data { my $self = shift; + my ($run, $job) = @_; - $self->check_for_fork; - - if (keys %{$self->{+PROCS}}) { - print "$$ $0 Sending all child processes the TERM signal...\n"; - # Send out the TERM signal - $self->killall($self->{+SIGNAL} // 'TERM'); - $self->wait(all => 1, timeout => 5); - } - - # Time to get serious - if (keys %{$self->{+PROCS}}) { - print STDERR "$$ $0 Some child processes are refusing to exit, sending KILL signal...\n"; - print("$$ $0 == $_ " . waitpid($_, WNOHANG) . "\n") for keys %{$self->{+PROCS}}; - $self->killall('KILL'); - } - - $self->SUPER::stop(); -} + my $run_id = $run->{run_id}; -sub dispatch_lock_file { - my $self = shift; - return $self->{+DISPATCH_LOCK_FILE} //= File::Spec->catfile($self->{+DIR}, 'dispatch.lock'); -} - -sub handle_sig { - my $self = shift; - my ($sig) = @_; - - return if $self->{+SIGNAL}; - - return $self->{+HANDLERS}->{$sig}->($sig) if $self->{+HANDLERS}->{$sig}; - - $self->{+SIGNAL} = $sig; - die "Runner caught SIG$sig. Attempting to shut down cleanly...\n"; -} - -sub all_libs { - my $self = shift; - - my @out; - - push @out => @{$self->{+INCLUDES}} if $self->{+INCLUDES}; - - push @out => 't/lib' if $self->{+TLIB}; - push @out => 'lib' if $self->{+LIB}; - - if ($self->{+BLIB}) { - push @out => 'blib/lib'; - push @out => 'blib/arch'; - } - - return @out; -} - -sub process { - my $self = shift; - - @INC = process_includes( - list => [@{$self->settings->harness->dev_libs}, $self->all_libs], - include_dot => $self->unsafe_inc, - include_current => 1, - clean => 1, + my $ts = Test2::Harness::TestSettings->merge( + $self->{+TEST_SETTINGS}, + $run->test_settings, + $job->test_file->test_settings ); - my $pidfile = File::Spec->catfile($self->{+DIR}, 'PID'); - write_file_atomic($pidfile, "$$"); - - $self->start(); - - my $ok = eval { $self->run_tests(); 1 }; - my $err = $@; - $self->{+CAN_STAGE} = 0; - - warn $err unless $ok; - - $self->stop(); - - return $self->{+SIGNAL} ? 128 + $self->SIG_MAP->{$self->{+SIGNAL}} : $ok ? 0 : 1; -} - -sub spawn_scheduler { - my $self = shift; - - return unless $self->{+ROOTPID} == $$; - - my $pid = fork // die "Could not fork: $!"; - return $self->watch_pid($pid) if $pid; - - my $guard = Scope::Guard->new(sub { - print STDERR "\n\nEscaped Scope!!!!\n\n"; - print STDERR $@; - exit 255; - }); - - $0 =~ s/-runner/-scheduler/i; - - my $state = $self->state; - - my $lock = open_file($self->dispatch_lock_file, '>>'); - - while (1) { - $state->poll; - - flock($lock, LOCK_EX) or die "Could not get scheduler lock: $!"; - - while (1) { - next if $state->advance; - last; - } - - flock($lock, LOCK_UN) or die "Could not release scheduler lock: $!"; - - if ($self->end_test_loop()) { - $guard->dismiss; - exit(0); - } - - sleep($self->{+WAIT_TIME}) if $self->{+WAIT_TIME}; - } - - warn "Escaped scheduler loop"; - exit 255; -} - -sub run_tests { - my $self = shift; - - my $preloader = $self->preloader; - $preloader->preload(); - - $self->spawn_scheduler(); - - my ($stage, @procs) = $preloader->preload_stages(); - - if ($self->dump_depmap) { - if (my $dtrace = $preloader->dtrace) { - if (my $depmap = $dtrace->dep_map) { - my $file = "depmap-$stage.json"; - write_file($file, encode_json($depmap)); - } - } - } - - $self->watch($_) for @procs; - - while(1) { - $self->{+CAN_STAGE} = 1; - my $jump = setjump "Stage-Runner" => sub { - $self->run_stage($stage); - }; - - last unless $jump; - - ($stage) = @$jump; - $self->reset_stage(); - } - - return; -} - -sub reset_stage { - my $self = shift; - - # Normalize IPC - $self->check_for_fork(); - - # If no stage was set we do not want to clear this, root stages need to - # preserve the preloads - return unless $self->{+STAGE}; - - # From Runner - delete $self->{+STAGE}; - delete $self->{+STATE}; - delete $self->{+LAST_TIMEOUT_CHECK}; - - return; -} - -sub run_stage { - my $self = shift; - my ($stage) = @_; - - $self->{+STAGE} = $stage; - $self->state->stage_ready($stage); - - while (1) { - next if $self->run_job(); - - next if $self->wait(); - - last if $self->end_test_loop(); - - sleep($self->{+WAIT_TIME}) if $self->{+WAIT_TIME}; - } + my $workdir = $self->{+WORKDIR}; - $self->state->stage_down($stage); - - $self->killall($self->{+SIGNAL}) if $self->{+SIGNAL}; - - $self->wait(all => 1); - - exit 0 unless $stage eq 'base' || $stage eq 'default'; + return { + workdir => $self->{+WORKDIR}, + run => $run->data_no_jobs, + job => $job, + test_settings => $ts, + root_pid => $$, + }; } -sub run_job { +sub launch_job { my $self = shift; + my ($stage, $run, $job) = @_; - my $task = $self->state->next_task($self->{+STAGE}) or return 0; - - if ($task->{spawn} && !$task->{resource_skip}) { - my $job = Test2::Harness::Runner::Spawn->new( - runner => $self, - task => $task, - settings => $self->settings, - fork_callback => $self->{+FORK_SPAWN_CALLBACK}, - ); - - $self->{+FORK_SPAWN_CALLBACK}->($self, $job); - return 1; - } - - my $run = $self->state->run(); - return 1 unless $run; - - my $job_class; - if ($task->{job_class}) { - $job_class = $task->{job_class}; - require(mod2file($job_class)); + croak "Invalid stage '$stage'" unless $stage eq 'NONE'; - die "Custom job class $job_class overrode the category, this is a fatal mistake" - unless $job_class->category eq $self->job_class->category; - } - else { - $job_class = $self->job_class; - } - - my $job = $job_class->new( - runner => $self, - task => $task, - run => $run, - settings => $self->settings, - fork_callback => $self->{+FORK_JOB_CALLBACK}, + my %seen; + my $pid = start_process( + $^X, # Call current perl + (map { ("-I$_") } grep { -d $_ && !$seen{$_}++ } @INC), # Use the dev libs specified + '-mTest2::Harness::Collector', # Load Collector + '-e' => 'exit(Test2::Harness::Collector->collect(json => $ARGV[0]))', # Run it. + encode_json($self->job_launch_data($run, $job)), # json data for job ); - $job->prepare_dir(); - - my $spawn_time; - - my $pid; - my $via = $job->via(); - if ($via) { - require(mod2file($1)) if !defined(&{$via}) && $via =~ m/^(.+)::[^:]+$/; - - $spawn_time = time(); - $pid = $self->$via($job); - $job->set_pid($pid); - $self->watch($job); - } - else { - $spawn_time = time(); - $self->spawn($job); - $pid = $job->pid; + local $? = 0; + my $check = waitpid($pid, 0); + my $exit = $?; + if ($exit || $check != $pid) { + my $x = parse_exit($exit); + warn "Collector failed ($check vs $pid) (Exit code: $x->{err}, Signal: $x->{sig})"; + return -1; } - my $json_data = $job->TO_JSON(); - $json_data->{stamp} = $spawn_time; - $run->jobs->write($json_data); - - return $pid; + return 1; } -sub end_test_loop { +sub terminate { my $self = shift; + my ($reason) = @_; - my $state = $self->state; - - no warnings 'uninitialized'; - if (!$self->{+STAGE} || $self->{+STAGE} eq 'default' || $self->{+STAGE} eq 'base') { - $self->{+RESPAWN_RUNNER_CALLBACK}->() - if $self->preloader->check($state) || ($self->{+SIGNAL} && $self->{+SIGNAL} eq 'HUP'); - } - - if ($self->preloader->check($state)) { - $self->{+SIGNAL} //= 'HUP'; - return 1; - } - - return 1 if $self->{+SIGNAL}; + $reason ||= 1; - return 1 if $state->done; - - return 0; + return $self->{+TERMINATED} ||= $reason; } -sub set_proc_exit { +sub DESTROY { my $self = shift; - my ($proc, $exit, $time, @args) = @_; - - if ($proc->isa('Test2::Harness::Runner::Job')) { - my $task = $proc->task; - - my $timed_out = 0; - if ( !$exit && ref $self->{run_reached_timeout} && $self->{run_reached_timeout}->{ $task->{job_id} } ) { - delete $self->{run_reached_timeout}->{ $task->{job_id} }; - $timed_out = 1; - } - - if (($exit || $timed_out) && $proc->is_try < $proc->retry ) { - $self->state->retry_task($task->{job_id}); - push @args => 'will-retry'; - } - else { - $self->state->stop_task($task->{job_id}); - } - - if(my $bail = $exit ? $proc->bailed_out : 0) { - print "$$ $0 BAIL-OUT detected: $bail\n"; - if ($self->settings->runner->abort_on_bail) { - print "$$ $0 Aborting the test run...\n"; - $self->state->halt_run($task->{run_id}); - } - } - } - elsif ($proc->isa('Test2::Harness::Runner::Preloader::Stage')) { - my $stage = $proc->name; - - if ($exit != 0) { - my $e = parse_exit($exit); - my $err = "$$ $0 Child stage '$stage' did not exit cleanly (sig: $e->{sig}, err: $e->{err})!\n"; - $self->{+MONITOR_PRELOADS} ? warn $err : die $err; - } - if ($self->{+MONITOR_PRELOADS} && $self->{+CAN_STAGE} && !$self->end_test_loop) { - my $pid = $$; - my ($name, @procs) = $self->preloader->_preload_stages($stage); - $self->watch($_) for @procs; - longjump "Stage-Runner" => $name unless $pid == $$; - } - } - - $self->SUPER::set_proc_exit($proc, $exit, $time, @args); + $self->terminate('DESTROY'); } 1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Runner - Base class for test runners - -=head1 DESCRIPTION - -This module does the heavy lifting of running all the tests. - -You should never need to create an instance of the runner yourself. In most -cases the runner module is exposed via a callback or a plugin affordance. - -=head1 PUBLIC METHODS - -=head2 FROM SETTINGS - -These are attributesd with values set from the L -instance created from command line arguments. - -See L for the most up to date documentation on -these. - -=over 4 - -=item $runner->includes - -=item $runner->tlib - -=item $runner->lib - -=item $runner->blib - -=item $runner->unsafe_inc - -=item $runner->use_fork - -=item $runner->preloads - -=item $runner->preload_threshold - -=item $runner->switches - -=item $runner->cover - -=item $runner->event_timeout - -=item $runner->post_exit_timeout - -=back - -=head2 FROM CONSTRUCTION - -These attributes are set when the runner is created. - -=over 4 - -=item $path = $runner->dir - -Path to the working directory. - -=item $settings = $runner->settings - -The L instance. - -=item $coderef = $runner->fork_job_callback - -Callback used to spawn new tests via fork. - -=item $coderef = $runner->respawn_runner_callback - -Callback to restart the runner process. - -=item $bool = $runner->monitor_preloads - -True if preloads should be watched for changes. - -=item $int = $runner->jobs_todo - -A count of total jobs to run. This will always be 0 in a persistent runner. - -=back - -=head2 OTHER PUBLIC METHODS - -If a method is not documented here then it is an implementation detail and you -should not use it. - -=over 4 - -=item $class = $runner->job_class - -Class for new test jobs. - -=item $preload = $runner->preloader - -Get the L instance. - -=item $state = $runner->state - -Get the L instance. - -=item @list = $runner->all_libs - -Get all the libs that should be added to @INC by default. Note that specific -runs and even specific tests can have custom paths on top of these. - -=back - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Runner/Constants.pm b/lib/Test2/Harness/Runner/Constants.pm deleted file mode 100644 index ce20a0380..000000000 --- a/lib/Test2/Harness/Runner/Constants.pm +++ /dev/null @@ -1,72 +0,0 @@ -package Test2::Harness::Runner::Constants; -use strict; -use warnings; - -our $VERSION = '1.000152'; - -use Importer Importer => 'import'; - -our @EXPORT = qw/CATEGORIES DURATIONS/; - -use constant CATEGORIES => {general => 1, isolation => 1, immiscible => 1}; -use constant DURATIONS => {long => 1, medium => 1, short => 1}; - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Runner::Constants - Constants shared between multiple runner -modules. - -=head1 DESCRIPTION - -Export some common structures. - -=head1 SYNOPSIS - - use Test2::Harness::Runner::Constants qw/CATEGORIES DURATIONS/; - - if (CATEGORIES->{$cat}) { - print "$cat is valid\n"; - } - else { - print "$cat is not valid\n"; - } - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Runner/DepTracer.pm b/lib/Test2/Harness/Runner/DepTracer.pm deleted file mode 100644 index 301ad0855..000000000 --- a/lib/Test2/Harness/Runner/DepTracer.pm +++ /dev/null @@ -1,283 +0,0 @@ -package Test2::Harness::Runner::DepTracer; -use strict; -use warnings; - -use Carp qw/croak/; - -our $VERSION = '1.000152'; - -use Test2::Harness::Util::HashBase qw/ - -_on - -exclude - -dep_map - -loaded - -my_require - -real_require - -_my_inc - -callbacks -/; - -my %DEFAULT_EXCLUDE = ( - 'warnings.pm' => 1, - 'strict.pm' => 1, -); - -my $ACTIVE; - -sub ACTIVE { $ACTIVE } - -sub start { - my $self = shift; - - croak "There is already an active DepTracer" if $ACTIVE; - - $ACTIVE = $self; - - unshift @INC => $self->my_inc; - - $self->{+_ON} = 1; -} - -sub stop { - my $self = shift; - - croak "DepTracer is not active" unless $ACTIVE; - croak "Different DepTracer is active" unless "$ACTIVE" eq "$self"; - $ACTIVE = undef; - - $self->{+_ON} = 0; - - my $inc = $self->{+_MY_INC} or return 0; - - @INC = grep { !(ref($_) && $inc == $_) } @INC; - return 0; -} - -sub my_inc { - my $self = shift; - - return $self->{+_MY_INC} if $self->{+_MY_INC}; - - my $exclude = $self->{+EXCLUDE} ||= {%DEFAULT_EXCLUDE}; - my $dep_map = $self->{+DEP_MAP} ||= {}; - my $loaded = $self->{+LOADED} ||= {}; - - return $self->{+_MY_INC} ||= sub { - my ($this, $file) = @_; - - return unless $self->{+_ON}; - return unless $file =~ m/^[_a-z]/i; - return if $exclude->{$file}; - - my $loaded_by = $self->loaded_by; - push @{$dep_map->{$file}} => $loaded_by; - $loaded->{$file}++; - - return; - }; -} - -sub clear_loaded { %{$_[0]->{+LOADED}} = () } - -my %REQUIRE_CACHE; - -sub add_callbacks { - my $self = shift; - my %watch = @_; - for my $file (keys %watch) { - my $cb = $watch{$file}; - $self->add_callback($file => $cb); - } -} - -sub add_callback { - my $self = shift; - my ($file, $cb) = @_; - $self->{+LOADED}->{$file}++; - $self->{+CALLBACKS}->{$file} = $cb; -} - -sub init { - my $self = shift; - - my $exclude = $self->{+EXCLUDE} ||= { %DEFAULT_EXCLUDE }; - - my $stash = \%CORE::GLOBAL::; - # We use a string in the reference below to prevent the glob slot from - # being auto-vivified by the compiler. - $self->{+REAL_REQUIRE} = exists $stash->{require} ? \&{'CORE::GLOBAL::require'} : undef; - - $self->{+CALLBACKS} //= {}; - my $dep_map = $self->{+DEP_MAP} ||= {}; - my $loaded = $self->{+LOADED} ||= {}; - my $inc = $self->my_inc; - - my $require = $self->{+MY_REQUIRE} = sub { - my ($file) = @_; - - my $loaded_by = $self->loaded_by; - - my $real_require = $self->{+REAL_REQUIRE}; - unless($real_require) { - my $caller = $loaded_by->[0]; - $real_require = $REQUIRE_CACHE{$caller} ||= eval "package $caller; sub { CORE::require(\$_[0]) }" or die $@; - } - - goto &$real_require unless $self->{+_ON}; - - if ($file =~ m/^[_a-z]/i) { - unless ($exclude->{$file}) { - push @{$dep_map->{$file}} => $loaded_by; - $loaded->{$file}++; - } - } - - if (!ref($INC[0]) || $INC[0] != $inc) { - @INC = ( - $inc, - grep { !(ref($_) && $inc == $_) } @INC, - ); - } - - local @INC = @INC[1 .. $#INC]; - - $real_require->(@_); - }; - - { - no strict 'refs'; - no warnings 'redefine'; - *{'CORE::GLOBAL::require'} = $require; - } -} - -sub loaded_by { - my $level = 1; - - while(my @caller = caller($level++)) { - next if $caller[0] eq __PACKAGE__; - - return [$caller[0], $caller[1]]; - } - - return ['', '']; -} - -1; - -__END__ - - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Runner::DepTracer - Tool for tracing module dependencies as -they are loaded. - -=head1 DESCRIPTION - -This tool is used by Test2::Harness to build a graph of dependancies which can -then be used to blacklist modified modules (and anything thatuses them) when -they change under a preloaded runner. - -=head1 SYNOPSIS - - use Test2::Harness::Runner::DepTracer; - - my $dt = Test2::Harness::Runner::DepTracer->new(); - - $dt->start(); - - require Some::Thing; - - # You can always check for and retrieve an active DepTrace this way: - my $dt_reference = Test2::Harness::Runner::DepTracer->ACTIVE; - - $dt->stop(); - - my $dep_map = $dt->dep_map; - - my $loaded_by = $dep_map->{'Some/Thing.pm'}; - print "Some::Thing was directly or indirectly loaded by:\n" . join("\n" => @$loaded_by) . "\n"; - -=head1 ATTRIBUTES - -These can be specified at construction, and will be populated during use. - -=over 4 - -=item $hashref = $dt->exclude - -A hashref of files/modules to exclude from dep tracking. By default C -and C are excluded. - -=item $hashref = $dt->dep_map - -Every file which is loaded while the tool is started will have an entry in this -hash, each value is an array of all files which loaded the key file directly or -indirectly. - -=item $hashref = $dt->loaded - -How many times each file was directly loaded. - -=back - -=head1 METHODS - -=over 4 - -=item $dt->start - -Start tracking modules which are loaded. - -=item $dt->stop - -Stop tracking moduels that are loaded. - -=back - -=head1 CLASS METHODS - -=over 4 - -=item $dt_or_undef = Test2::Harness::Runner::DepTracer->ACTIVE(); - -Get the currently active DepTracer, if any. - -=back - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Runner/Job.pm b/lib/Test2/Harness/Runner/Job.pm deleted file mode 100644 index ec2378382..000000000 --- a/lib/Test2/Harness/Runner/Job.pm +++ /dev/null @@ -1,828 +0,0 @@ -package Test2::Harness::Runner::Job; -use strict; -use warnings; - -our $VERSION = '1.000152'; - -use Carp qw/confess croak/; -use Config qw/%Config/; -use List::Util qw/min/; -use Scalar::Util qw/weaken blessed/; -use Test2::Util qw/CAN_REALLY_FORK/; -use Time::HiRes qw/time/; - -use File::Spec(); -use File::Temp(); - -use Test2::Harness::Util qw/fqmod clean_path write_file_atomic write_file mod2file open_file parse_exit process_includes chmod_tmp/; -use Test2::Harness::IPC; - -use parent 'Test2::Harness::IPC::Process'; -use Test2::Harness::Util::HashBase( - qw{ {+RUNNER}; - croak "'run' is a required attribute" unless $self->{+RUN}; - croak "'settings' is a required attribute" unless $self->{+SETTINGS}; - - delete $self->{+JOB_DIR}; - - # Avoid a ref cycle - #weaken($self->{+RUNNER}); - - my $task = $self->{+TASK} or croak "'task' is a required attribute"; - - delete $self->{+LAST_OUTPUT_SIZE}; - - confess "Task does not have a job ID" unless $task->{job_id}; - confess "Task does not have a file" unless $task->{file}; -} - -sub job_id { $_[0]->{+TASK}->{job_id} } - -sub prepare_dir { - my $self = shift; - - $self->job_dir(); - $self->tmp_dir(); - $self->event_dir(); -} - -sub via { - my $self = shift; - - return undef if $self->{+SETTINGS}->debug->dummy; - return undef if $self->{+TASK}->{resource_skip}; - - return $self->{+VIA} if exists $self->{+VIA}; - - my $task = $self->{+TASK}; - return $self->{+VIA} = $task->{via} if $task->{via}; - - return $self->{+VIA} = $self->{+FORK_CALLBACK} if $self->{+FORK_CALLBACK} && $self->use_fork; - - return $self->{+VIA} = undef; -} - -sub spawn_params { - my $self = shift; - - my $task = $self->{+TASK}; - - my $skip; - $skip = 'dummy mode' if $self->{+SETTINGS}->debug->dummy; - $skip = "Some resources are not available: " . join(', ' => @{$self->{+TASK}->{resource_skip}}) if $self->{+TASK}->{resource_skip}; - - my $command; - if (!$skip && $task->{binary} || $task->{non_perl}) { - my $file = $self->ch_dir ? $self->file : $self->rel_file; - $command = [clean_path($file), $self->args]; - } - else { - $command = [ - $^X, - $self->cli_includes, - $self->{+SETTINGS}->runner->nytprof ? ('-d:NYTProf') : (), - $self->switches, - $self->cli_options, - - $skip ? ('-e', "print \"1..0 # SKIP $skip\"") : (sub { $self->run_file }), - - $self->args, - ]; - } - - my $out_fh = open_file($self->out_file, '>'); - my $err_fh = open_file($self->err_file, '>'); - my $in_fh = open_file($self->in_file, '<'); - - return { - command => $command, - stdin => $in_fh, - stdout => $out_fh, - stderr => $err_fh, - chdir => $self->ch_dir(), - env => $self->env_vars(), - }; -} - -sub switches_from_env { - my $self = shift; - - return @{$self->{+SWITCHES_FROM_ENV}} if $self->{+SWITCHES_FROM_ENV}; - - return @{$self->{+SWITCHES_FROM_ENV} = []} unless $ENV{HARNESS_PERL_SWITCHES}; - - return @{$self->{+SWITCHES_FROM_ENV} = [split /\s+/, $ENV{HARNESS_PERL_SWITCHES}]}; -} - -my %JSON_SKIP = ( - SETTINGS() => 1, - TASK() => 1, - RUNNER() => 1, - RUN() => 1, - CLI_INCLUDES() => 1, - CLI_OPTIONS() => 1, - ERR_FILE() => 1, - ET_FILE() => 1, - EVENT_DIR() => 1, - EXIT() => 1, - EXIT_TIME() => 1, - IN_FILE() => 1, - JOB_DIR() => 1, - LAST_OUTPUT_SIZE() => 1, - OUT_FILE() => 1, - BAIL_FILE() => 1, - OUTPUT_CHANGED() => 1, - PET_FILE() => 1, - RUN_DIR() => 1, - TMP_DIR() => 1, -); - -sub TO_JSON { - my $self = shift; - - my $out = { %{$self->{+TASK}} }; - - for my $attr (Test2::Harness::Util::HashBase::attr_list(blessed($self))) { - next if $JSON_SKIP{$attr}; - $self->$attr unless defined $self->{$attr}; - $out->{$attr} = $self->{$attr}; - } - - delete $out->{+FORK_CALLBACK}; - delete $out->{+VIA} if ref($out->{+VIA}) eq 'CODE'; - - $out->{job_name} //= $out->{job_id}; - $out->{abs_file} = clean_path($self->file); - - return $out; -} - -sub run_file { - my $self = shift; - return $self->{+RUN_FILE} //= $self->rel_file; -} - -sub rel_file { File::Spec->abs2rel($_[0]->file) } -sub file { $_[0]->{+FILE} //= clean_path($_[0]->{+TASK}->{file}, 0) } -sub err_file { $_[0]->{+ERR_FILE} //= clean_path(File::Spec->catfile($_[0]->job_dir, 'stderr')) } -sub out_file { $_[0]->{+OUT_FILE} //= clean_path(File::Spec->catfile($_[0]->job_dir, 'stdout')) } -sub bail_file { $_[0]->{+BAIL_FILE} //= clean_path(File::Spec->catfile($_[0]->event_dir, 'bail')) } -sub et_file { $_[0]->{+ET_FILE} //= clean_path(File::Spec->catfile($_[0]->job_dir, 'event_timeout')) } -sub pet_file { $_[0]->{+PET_FILE} //= clean_path(File::Spec->catfile($_[0]->job_dir, 'post_exit_timeout')) } -sub run_dir { $_[0]->{+RUN_DIR} //= clean_path(File::Spec->catdir($_[0]->{+RUNNER}->dir, $_[0]->{+RUN}->run_id)) } - -sub bailed_out { - my $self = shift; - - if(-f $self->bail_file) { - my $fh = open_file($self->bail_file, '<'); - my $reason = <$fh> || 1; - return $reason; - } - - my $fh = open_file($self->out_file, '<'); - while (my $line = <$fh>) { - next unless $line =~ m/^Bail out!\s*(.*)$/; - return $1 || 1; - } - - return ""; -} - -sub output_size { - my $self = shift; - - my $size = 0; - - $size += -s $self->err_file || 0; - $size += -s $self->out_file || 0; - - return $self->{+LAST_OUTPUT_SIZE} = $size; -} - -sub output_changed { - my $self = shift; - - my $last = $self->{+LAST_OUTPUT_SIZE}; - my $size = $self->output_size(); - - # Output changed, update time - return $self->{+OUTPUT_CHANGED} = time() if $last && $size != $last; - - # Return the last recorded time, if there is no previously recorded time then the record starts now - return $self->{+OUTPUT_CHANGED} //= time(); -} - -sub verbose { $_[0]->{+VERBOSE} //= $_[0]->{+TASK}->{verbose} // 0 } -sub is_try { $_[0]->{+IS_TRY} //= $_[0]->{+TASK}->{is_try} // 0 } -sub ch_dir { $_[0]->{+CH_DIR} //= $_[0]->{+TASK}->{ch_dir} // '' } -sub unsafe_inc { $_[0]->{+UNSAFE_INC} //= $_[0]->{+RUNNER}->unsafe_inc } -sub event_uuids { $_[0]->{+EVENT_UUIDS} //= $_[0]->run->event_uuids } -sub mem_usage { $_[0]->{+MEM_USAGE} //= $_[0]->run->mem_usage } - -sub io_events { $_[0]->{+IO_EVENTS} //= $_[0]->_fallback(io_events => 1, qw/task run/) } - -sub smoke { $_[0]->{+SMOKE} //= $_[0]->_fallback(smoke => 0, qw/task/) } -sub retry_isolated { $_[0]->{+RETRY_ISOLATED} //= $_[0]->_fallback(retry_isolated => 0, qw/task run/) } -sub use_stream { $_[0]->{+USE_STREAM} //= $_[0]->_fallback(use_stream => 1, qw/task run/) } -sub use_timeout { $_[0]->{+USE_TIMEOUT} //= $_[0]->_fallback(use_timeout => 1, qw/task/) } -sub retry { $_[0]->{+RETRY} //= $_[0]->_fallback(retry => undef, qw/task run/) } -sub event_timeout { $_[0]->{+EVENT_TIMEOUT} //= $_[0]->_fallback(event_timeout => undef, qw/task runner/) } -sub post_exit_timeout { $_[0]->{+POST_EXIT_TIMEOUT} //= $_[0]->_fallback(post_exit_timeout => undef, qw/task runner/) } - -sub min_slots { $_[0]->{+MIN_SLOTS} //= $_[0]->_fallback_non_bool(min_slots => 1, qw/task/) } -sub max_slots { $_[0]->{+MAX_SLOTS} //= $_[0]->_fallback_non_bool(max_slots => 1, qw/task/) } - -sub args { @{$_[0]->{+ARGS} //= $_[0]->_merge_sources(test_args => qw/task run/)} } -sub load { @{$_[0]->{+LOAD} //= [@{$_[0]->run->load // []}]} } - -sub cli_includes { - my $self = shift; - - # '.' is handled via the PERL_USE_UNSAFE_INC env var set later - $self->{+CLI_INCLUDES} //= [map { "-I$_" } grep { $_ ne '.' } $self->includes]; - - return @{$self->{+CLI_INCLUDES}}; -} - -sub runner_includes { @{$_[0]->{+RUNNER_INCLUDES} //= [$_[0]->{+RUNNER}->all_libs]} } - -sub _merge_sources { - my $self = shift; - my ($name, @from) = @_; - - my @vals; - for my $from (@from) { - my $source = $self->$from; - my $val = blessed($source) ? $source->$name : $source->{$name}; - next unless defined $val; - next unless @$val; - push @vals => @$val; - } - - return \@vals; -} - -sub _fallback_non_bool { - my $self = shift; - my ($name, $default, @from) = @_; - - for my $from (@from) { - my $source = $self->$from; - my $val = blessed($source) ? $source->$name : $source->{$name}; - return $val if defined $val; - } - - return $default; -} - -sub _fallback { - my $self = shift; - my ($name, $default, @from) = @_; - - my @vals; - for my $from (@from) { - my $source = $self->$from; - my $val = blessed($source) ? $source->$name : $source->{$name}; - push @vals => $val if defined $val; - } - - return $default unless @vals; - - # If the default is a ref we will just return the first value we found, truthiness check is useless - return shift @vals if ref $default || !defined($default) || $default !~ m/^(0|1)$/; - - # If the default is true, then we only return true if none of the vals are false - return !grep { !$_ } @vals if $default; - - # If the default is false, then we return true if any of the valse are true - return grep { $_ } @vals; -} - -sub job_dir { - my $self = shift; - return $self->{+JOB_DIR} if $self->{+JOB_DIR}; - - my $job_dir = File::Spec->catdir($self->run_dir, $self->{+TASK}->{job_id} . '+' . $self->is_try); - mkdir($job_dir) or die "$$ $0 Could not create job directory '$job_dir': $!"; - chmod_tmp($job_dir); - $self->{+JOB_DIR} = $job_dir; -} - -sub tmp_dir { - my $self = shift; - - return $self->{+TMP_DIR} if $self->{+TMP_DIR}; - - my $tmp_dir = File::Temp::tempdir("XXXXXX", DIR => $self->runner->tmp_dir); - chmod_tmp($tmp_dir); - - $self->{+TMP_DIR} = clean_path($tmp_dir); -} - -sub make_event_dir { $_[0]->event_dir } -sub event_dir { - my $self = shift; - return $self->{+EVENT_DIR} if $self->{+EVENT_DIR}; - - my $events_dir = File::Spec->catdir($self->job_dir, 'events'); - unless (-d $events_dir) { - mkdir($events_dir) or die "$$ $0 Could not create events directory '$events_dir': $!"; - } - $self->{+EVENT_DIR} = $events_dir; -} - -sub in_file { - my $self = shift; - return $self->{+IN_FILE} if $self->{+IN_FILE}; - - my $task = $self->{+TASK}; - - unless ($task->{input}) { - my $from_run = $self->run->input_file; - return $self->{+IN_FILE} = $from_run if $from_run; - } - - my $stdin = File::Spec->catfile($self->job_dir, 'stdin'); - - my $content = $task->{input} // $self->run->input // ''; - write_file($stdin, $content); - - return $self->{+IN_FILE} = $stdin; -} - -sub use_fork { - my $self = shift; - - return $self->{+USE_FORK} if defined $self->{+USE_FORK}; - - my $task = $self->{+TASK}; - - return $self->{+USE_FORK} = 0 unless CAN_REALLY_FORK; - return $self->{+USE_FORK} = 0 if $task->{binary}; - return $self->{+USE_FORK} = 0 if $task->{non_perl}; - return $self->{+USE_FORK} = 0 if defined($task->{use_fork}) && !$task->{use_fork}; - return $self->{+USE_FORK} = 0 if defined($task->{use_preload}) && !$task->{use_preload}; - - # -w switch is ok, otherwise it is a no-go - return $self->{+USE_FORK} = 0 if grep { !m/\s*-w\s*/ } $self->switches; - - my $runner = $self->{+RUNNER}; - return $self->{+USE_FORK} = 0 unless $runner->use_fork; - - return $self->{+USE_FORK} = 1; -} - -sub includes { - my $self = shift; - - return @{$self->{+INCLUDES}} if $self->{+INCLUDES}; - - $self->{+INCLUDES} = [ - process_includes( - list => [$self->runner_includes, @{$self->{+SETTINGS}->harness->orig_inc}], - include_dot => $self->unsafe_inc, - include_current => 1, - clean => 1, - $self->ch_dir ? (ch_dir => $self->ch_dir) : (), - ) - ]; - - return @{$self->{+INCLUDES}}; -} - -sub cli_options { - my $self = shift; - - my $event_dir = $self->event_dir; - my $job_id = $self->job_id; - - return ( - $self->use_stream ? ("-MTest2::Formatter::Stream=dir,$event_dir,job_id,$job_id") : (), - $self->event_uuids ? ('-MTest2::Plugin::UUID') : (), - $self->mem_usage ? ('-MTest2::Plugin::MemUsage') : (), - $self->io_events ? ('-MTest2::Plugin::IOEvents') : (), - (map { @{$_->[1]} ? "-M$_->[0]=" . join(',' => @{$_->[1]}) : "-M$_->[0]" } $self->load_import), - (map { "-m$_" } $self->load), - ); -} - -sub switches { - my $self = shift; - - return @{$self->{+SWITCHES}} if $self->{+SWITCHES}; - - my @switches; - - my %seen; - for my $s (@{$self->{+TASK}->{switches} // []}) { - $seen{$s}++; - $self->{+USE_W_SWITCH} = 1 if $s =~ m/\s*-w\s*/; - push @switches => $s; - } - - my %seen2; - for my $s (@{$self->{+RUNNER}->switches // []}) { - next if $seen{$s}; - $seen2{$s}++; - $self->{+USE_W_SWITCH} = 1 if $s =~ m/\s*-w\s*/; - push @switches => $s; - } - - for my $s ($self->switches_from_env) { - next if $seen{$s}; - next if $seen2{$s}; - $self->{+USE_W_SWITCH} = 1 if $s =~ m/\s*-w\s*/; - push @switches => $s; - } - - return @{$self->{+SWITCHES} = \@switches}; -} - -sub prof_file { - my $self = shift; - my $file =$self->rel_file; - - $file =~ s{/}{-}g; - $file =~ s{\.[^\.]+$}{.nytprof}g; - - return $file; -} - -sub env_vars { - my $self = shift; - - return $self->{+ENV_VARS} if $self->{+ENV_VARS}; - - my $from_run = $self->run->env_vars; - my $from_task = $self->{+TASK}->{env_vars}; - - my @p5l = ($from_task->{PERL5LIB}, $from_run->{PERL5LIB}); - push @p5l => $self->includes if $self->{+TASK}->{binary} || $self->{+TASK}->{non_perl}; - push @p5l => $ENV{PERL5LIB} if $ENV{PERL5LIB}; - my $p5l = join $Config{path_sep} => grep { defined $_ && $_ ne '.' } @p5l; - - my $verbose = $self->verbose; - - return $self->{+ENV_VARS} = { - $from_run ? (%$from_run) : (), - $from_task ? (%$from_task) : (), - - $self->use_stream ? (T2_FORMATTER => 'Stream', T2_STREAM_DIR => $self->event_dir, T2_STREAM_JOB_ID => $self->job_id) : (), - - $self->{+SETTINGS}->runner->nytprof ? (NYTPROF => "addpid=1:start=begin") : (), - - PERL5LIB => $p5l, - PERL_USE_UNSAFE_INC => $self->unsafe_inc, - TEST2_JOB_DIR => $self->job_dir, - TEST2_RUN_DIR => $self->run_dir, - TMPDIR => $self->tmp_dir, - TEMPDIR => $self->tmp_dir, - SYSTEM_TMPDIR => $self->{+SETTINGS}->harness->orig_tmp, - SYSTEM_TMPDIR_PERMS => $self->{+SETTINGS}->harness->orig_tmp_perms, - - HARNESS_IS_VERBOSE => $verbose, - T2_HARNESS_IS_VERBOSE => $verbose, - - HARNESS_ACTIVE => 1, - TEST2_HARNESS_ACTIVE => 1, - - T2_HARNESS_JOB_FILE => $self->rel_file, - T2_HARNESS_JOB_NAME => $self->{+TASK}->{job_name}, - T2_HARNESS_JOB_IS_TRY => $self->{+IS_TRY} // 0, - T2_HARNESS_JOB_DURATION => $self->{+TASK}->{duration} // '', - }; -} - -sub load_import { - my $self = shift; - - return @{$self->{+LOAD_IMPORT}} if $self->{+LOAD_IMPORT}; - - my $from_run = $self->run->load_import; - - my @out; - for my $mod (@{$from_run->{'@'} // []}) { - push @out => [$mod, $from_run->{$mod} // []]; - } - - return @{$self->{+LOAD_IMPORT} = \@out}; -} - -sub use_w_switch { - my $self = shift; - return $self->{+USE_W_SWITCH} if defined $self->{+USE_W_SWITCH}; - $self->switches; - return $self->{+USE_W_SWITCH}; -} - -sub set_exit { - my $self = shift; - my ($runner, $exit, $time, @args) = @_; - - $self->SUPER::set_exit(@_); - - my $file = File::Spec->catfile($self->job_dir, 'exit'); - - my $e = parse_exit($exit); - - write_file_atomic($file, join(" " => $exit, $e->{err}, $e->{sig}, $e->{dmp}, $time, @args)); -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Runner::Job - Representation of a test job. - -=head1 DESCRIPTION - -This module takes all the data from a test file queue item, a run, and runner -settings, and mashes them together to figure out what is actually needed to run -a job. - -=head1 METHODS - -Note, this object subclasses L. - -=over 4 - -=item $arrayref = $job->args - -Get the arguments for the test either formt he queue item, or from the run. - -=item $path = $job->bail_file - -Path to the events-file used in case of a bail-out - -=item $bool = $job->bailed_out - -True if the test job bailed out. - -=item $cat $job->category - -Process category, always 'job' unless overriden in a subclass. - -=item $path = $job->ch_dir - -If this job first requires a change in directory before running, this will -return the path. - -=item @list = $job->cli_includes - -List of includes for a command line launch of this job. - -=item @list = $job->cli_options - -List of options for a command line launch of this job. - -=item $hashref = $job->env_vars - -Get environment variables to set when launching this job. - -=item $path = $job->out_file - -File to which all STDOUT for the job will be written. - -=item $path = $job->err_file - -File to which all STDERR for the job will be written. - -=item $path = $job->et_file - -File to which event timeout notifications will be written. - -=item $path = $job->pet_file - -File to which post exit timeout events will be written. - -=item $path = $job->event_dir - -Directory to which L events will be written. - -=item $time = $job->event_timeout - -Event timeout specification, if any, first from test queue item, then from -runner. - -=item $time = $job->post_exit_timeout - -Post exit timeout specification, if any, first from test queue item, then from -runner. - -=item $bool = $job->event_uuids - -Use L inside the test. - -=item $path = $job->file - -Test file the job will be running. - -=item $coderef = $job->fork_callback - -If the job is to be launched via fork, use this callback. - -=item $path = $job->in_file - -File containing STDIN to be provided to the test. - -=item @list = $job->includes - -Paths to add to @INC for the test. - -=item $bool = $job->io_events - -True if L should be used. - -=item $int = $job->is_try - -This starts at 0 and will be incremented for every retry of the job. - -=item $path = $job->job_dir - -Temporary directory housing all files related to this job when it runs. - -=item $uuid = $job->job_id - -UUID for this job. - -=item @list = $job->load - -Modules to load when starting this job. - -=item @list = $job->load_import - -Modules to load and import when starting this job. - -=item $bool = $job->mem_usage - -True if the L plugin should be used. - -=item $path = $job->run_file - -Usually the same as rel_file, but you can specify an alternative file to -actually run. - -=item $path = $job->rel_file - -Relative path to the file. - -=item $int = $job->retry - -How many times the test should be retried if it fails. - -=item $bool = $job->retry_isolated - -True if the test should be retried in isolation if it fails. - -=item $run = $job->run - -The L instance. - -=item $path = $job->run_dir - -Path to the temporary directory housing all the data about the run. - -=item $runner = $job->runner - -The L instance. - -=item @list = $job->runner_includes - -Search path includes provided directly by the runner. - -=item $settings = $job->settings - -The L instance. - -=item $bool = $job->smoke - -True if the test is a priority smoke test. - -=item $hashref = $job->spawn_params - -Parameters for C in L when launching this -job. - -=item @list = $job->switches - -Command line switches for perl when running this test. - -=item $hashref = $job->task - -Task data from the queue. - -=item $path = $job->tmp_dir - -Temp dir created specifically for this job. - -=item $bool = $job->unsafe_inc - -True if '.' should be added to C<@INC>. - -=item $bool = $job->use_fork - -True if this job should be launched via fork. - -=item $bool = $job->use_stream - -True if this job should use L. - -=item $bool = $job->use_timeout - -True if this job should timeout due to lack of activity. - -=item $bool = $job->use_w_switch - -True if the C<-w> switch should be used for this test. - -=back - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Runner/Preload.pm b/lib/Test2/Harness/Runner/Preload.pm index f09708fc7..26905eccb 100644 --- a/lib/Test2/Harness/Runner/Preload.pm +++ b/lib/Test2/Harness/Runner/Preload.pm @@ -2,568 +2,12 @@ package Test2::Harness::Runner::Preload; use strict; use warnings; -our $VERSION = '1.000152'; +our $VERSION = '2.000000'; -use Carp qw/croak/; +use Carp qw/cluck/; -use Test2::Harness::Runner::Preload::Stage(); +use parent 'Test2::Harness::Preload'; -sub import { - my $class = shift; - my $caller = caller; - - my %exports; - - my $instance = $class->new; - - $exports{TEST2_HARNESS_PRELOAD} = sub { $instance }; - - $exports{stage} = sub { - my ($name, $code) = @_; - my @caller = caller(); - $instance->build_stage( - name => $name, - code => $code, - caller => \@caller, - ); - }; - - $exports{eager} = sub { - croak "No current stage" unless @{$instance->stack}; - my $stage = $instance->stack->[-1]; - $stage->set_eager(1); - }; - - $exports{default} = sub { - croak "No current stage" unless @{$instance->stack}; - my $stage = $instance->stack->[-1]; - my $name = $stage->name; - $instance->set_default_stage($name); - }; - - $exports{file_stage} = sub { - my ($callback) = @_; - my @caller = caller(); - croak "'file_stage' cannot be used under a stage" if @{$instance->stack}; - $instance->add_file_stage(\@caller, $callback); - }; - - for my $name (qw/pre_fork post_fork pre_launch/) { - my $meth = "add_${name}_callback"; - $exports{$name} = sub { - croak "No current stage" unless @{$instance->stack}; - my $stage = $instance->stack->[-1]; - $stage->$meth(@_); - }; - } - - $exports{watch} = sub { - if (@{$instance->stack}) { - my $stage = $instance->stack->[-1]; - return $stage->watch(@_); - } - - if ($INC{'Test2/Harness/Runner/DepTracer.pm'}) { - if (my $active = Test2::Harness::Runner::DepTracer->ACTIVE) { - return $active->add_callback(@_); - } - } - - croak "No current stage, and no active deptracer"; - }; - - $exports{preload} = sub { - croak "No current stage" unless @{$instance->stack}; - my $stage = $instance->stack->[-1]; - $stage->add_to_load_sequence(@_); - }; - - $exports{reload_remove_check} = sub { - croak "No current stage" unless @{$instance->stack}; - my $stage = $instance->stack->[-1]; - $stage->set_reload_remove_check(@_); - }; - - $exports{reload_inplace_check} = sub { - croak "No current stage" unless @{$instance->stack}; - my $stage = $instance->stack->[-1]; - $stage->set_reload_inplace_check(@_); - }; - - for my $name (keys %exports) { - no strict 'refs'; - *{"$caller\::$name"} = $exports{$name}; - } -} - -use Test2::Harness::Util::HashBase qw{ - {+STAGE_LIST} //= []; - $self->{+STAGE_LOOKUP} //= {}; - - $self->{+STACK} //= []; - - $self->{+FILE_STAGE} //= []; -} - -sub build_stage { - my $self = shift; - my %params = @_; - - my $caller = $params{caller} //= [caller()]; - - die "A coderef is required at $caller->[1] line $caller->[2].\n" - unless $params{code}; - - my $stage = Test2::Harness::Runner::Preload::Stage->new( - stage_lookup => $self->{+STAGE_LOOKUP}, - %params, - ); - - my $stack = $self->{+STACK} //= []; - push @$stack => $stage; - - my $ok = eval { $params{code}->($stage); 1 }; - my $err = $@; - - die "Mangled stack" unless @$stack && $stack->[-1] eq $stage; - - pop @$stack; - - die $err unless $ok; - - if (@$stack) { - $stack->[-1]->add_child($stage); - } - else { - $self->add_stage($stage, $caller); - } - - return $stage; -} - -sub add_stage { - my $self = shift; - my ($stage, $caller) = @_; - - $caller //= [caller()]; - - my @all = ($stage, @{$stage->all_children}); - - for my $item (@all) { - my $name = $item->name; - - if (my $existing = $self->{+STAGE_LOOKUP}->{$name}) { - $caller //= [caller()]; - my $ncaller = $item->frame; - my $ecaller = $existing->frame; - die <<" EOT" -A stage named '$name' was already defined. - First at $ecaller->[1] line $ecaller->[2]. - Second at $ncaller->[1] line $ncaller->[2]. - Mixed at $caller->[1] line $caller->[2]. - EOT - } - - $self->{+STAGE_LOOKUP}->{$name} = $item; - } - - push @{$self->{+STAGE_LIST}} => $stage; -} - -sub merge { - my $self = shift; - my ($merge) = @_; - - my $caller = [caller()]; - - for my $stage (@{$merge->{+STAGE_LIST}}) { - $self->add_stage($stage, $caller); - } - - push @{$self->{+FILE_STAGE}} => @{$merge->{+FILE_STAGE}}; - - $self->{+DEFAULT_STAGE} //= $merge->default_stage; -} - -sub add_file_stage { - my $self = shift; - my ($caller, $code) = @_; - - croak "Caller must be defined and an array" unless $caller && ref($caller) eq 'ARRAY'; - croak "Code must be defined and a coderef" unless $code && ref($code) eq 'CODE'; - - push @{$self->{+FILE_STAGE}} => [$caller, $code]; -} - -sub file_stage { - my $self = shift; - my ($file) = @_; - - for my $cb (@{$self->{+FILE_STAGE}}) { - my ($caller, $code) = @$cb; - my $stage = $code->($file) or next; - - die "file_stage callback returned invalid stage: $stage at $caller->[1] line $caller->[2].\n" - unless $self->{+STAGE_LOOKUP}->{$stage}; - - return $stage; - } - - return; -} - -sub default_stage { - my $self = shift; - return $self->{+DEFAULT_STAGE} if $self->{+DEFAULT_STAGE}; - return $self->{+STAGE_LIST}->[0]; -} - -sub set_default_stage { - my $self = shift; - my ($name) = @_; - - croak "Default stage already set to $self->{+DEFAULT_STAGE}" if $self->{+DEFAULT_STAGE}; - $self->{+DEFAULT_STAGE} = $name; -} - -sub eager_stages { - my $self = shift; - - my %eager; - - for my $root (@{$self->{+STAGE_LIST}}) { - for my $stage ($root, @{$root->all_children}) { - next unless $stage->eager; - $eager{$stage->name} = [map { $_->name } @{$stage->all_children}]; - } - } - - return \%eager; -} +cluck "Test2::Harness::Runner::Preload is deprecated, use Test2::Harness::Preload instead (hint 'Runner::' has been removed)"; 1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Runner::Preload - DSL for building complex stage-based preload -tools. - -=head1 DESCRIPTION - -L allows you to preload libraries for a performance boost. This -module provides tools that let you go beyond that and build a more complex -preload. In addition you can build multiple preload I, each stage will -be its own process and tests can run from a specific stage. This allows for -multiple different preload states from which to run tests. - -=head1 SYNOPSIS - -=head2 USING YOUR PRELOAD - -The C<-P> or C<--preload> options work for custom preload modules just as they -do regular modules. Yath will know the difference and act accordingly. - - yath test -PMy::Preload - -=head2 WRITING YOUR PRELOAD - - package My::Preload; - use strict; - use warnings; - - # This imports several useful tools, and puts the necessary meta-data in - # your package to identify it as a special preload. - use Test2::Harness::Runner::Preload; - - # You must specify at least one stage. - stage Moose => sub { - # Preload can be called multiple times, and can load multiple modules - # per call. Order is preserved. - preload 'Moose', 'Moose::Role'; - preload 'Scalar::Util', 'List::Util'; - - # preload can also be given a sub if you have some custom code to run - # at a specific point in the load order - preload sub { - # Do something before loading Try::Tiny - ... - }; - - preload 'Try::Tiny'; - - # Tell the runner to watch this file for changes, if it does change run - # the sub instead of the usual reload process. This lets you reload - # configs and other non-perl files, or allows you to use a custom - # reload sub for perl files. - watch 'path/to/file' => sub { ... }; - - # You can also use watch inside preload subs: - preload sub { - watch 'path/to/file' => sub { ... }; - }; - - # In app code you can add watches dynamically when applicable: - preload sub { - ... # inside app code - - if ($INC{'Test2/Harness/Runner/DepTracer.pm'}) { - if (my $active = Test2::Harness::Runner::DepTracer->ACTIVE) { - $active->add_callback('path/to/file' => sub { ... }); - } - } - - ... - }; - - # Eager means tests from nested stages can be run in this stage as - # well, this is useful if the nested stage takes a long time to load as - # it allows yath to start running tests sooner instead of waiting for - # the stage to finish loading. Once the nested stage is loaded tests - # intended for it will start running from it instead. - eager(); - - # default means this stage is the one to use if the test does not - # specify a stage. - default(); - - # These are hooks that let you run arbitrary code at specific points in - # the process. pre_fork happens just before forking to run a test. - # post_fork happens just after forking for a test. pre_launch happens - # as late as possible before the test starts executing (post fork, - # after $0 and other special state are reset). - pre_fork sub { ... }; - post_fork sub { ... }; - pre_launch sub { ... }; - - # Stages can be nested, nested ones build off the previous stage, but - # are in a forked process to avoid contaminating the parent. - stage Types => sub { - preload 'MooseX::Types'; - }; - }; - - # Alternative stage that loads Moo instead of Moose - stage Moo => sub { - preload 'Moo'; - - ... - }; - -=head2 HARNESS DIRECTIVES IN PRELOADS - -If you use a staged preload, and the --reload option, you can add 'CHURN' -directives to files in order to only reload sections you are working on. This -is particularly useful when a file cannot be reloaded in full, or when doing so -is expensive. You can wrap subroutines in the churn directives to have yath -reload only those subroutines. - - sub do_not_reload_this { ... { - - # HARNESS-CHURN-START - - sub reload_this_one { - ... - } - - sub reload_this_one_too { - ... - } - - # HARNESS-CHURN-STOP - - sub this_is_not_reloaded { ... } - -You can put as many churn sections you want in as many preloaded modules as you -want. If a change is detected then only the churn sections will be reloaded. -The churn sections are reloaded by taking the source between the start and stop -markers, and running them in an eval like this: - - eval < statement inside the markers. If the strict/warnings settings are not to -your specifications you can add overrides inside the markers. Any valid perl -code can go into the markers. - -B Be aware they do not have their original scope, and that can lead -to problems if you are not paying attention. Variables outside your markers are -not accessible, and lexical variables put inside your markers will be "new" on -each reload, this can cause confusion if you have lexicals used by multiple -subs where some are inside churn blocks and others are not, so best not to do -that. Package variables work a bit better, but any assignment lines are re-run. -So C is fine (it does not change the value if it is set) but -C will reset the var on each reload. - -=head1 EXPORTS - -=over 4 - -=item $meta = TEST2_HARNESS_PRELOAD() - -=item $meta = $class->TEST2_HARNESS_PRELOAD() - -This export provides the meta object, which is an instance of this class. This -method being present is how Test2::Harness differentiates between a regular -module and a special preload library. - -=item stage NAME => sub { ... } - -This creates a new stage with the given C, and then runs the coderef with -the new stage set as the I one upon which the other function here will -operate. Once the coderef returns the I stage is cleared. - -You may nest stages by calling this function again inside the codeblock. - -B stage names B case sensitive. This can be confusing when you -consider that most harness directives are all-caps. In the following case the -stage requested by the test and the stage defined in -the library are NOT the same. - -In a test file: - - # HARNESS-STAGE-FOO - -In a preload library: - - stage foo { ... } - -Harness directives are all-caps, however the user data portion need not be, -this is fine: - - # HARNESS-STAGE-foo - -However it is very easy to make the mistake of thinking it is case insensitive. -It is also easy to assume the 'foo' part of the harness directive must be all -caps. In many cases it is smart to make your stage names all-caps. - -=item preload $module_name - -=item preload @module_names - -=item preload sub { ... } - -This B be called inside a C builder coderef. - -This adds modules to the list of libraries to preload. Order is preserved. You -can also add coderefs to execute arbitrary code between module loads. - -The coderef is called with no arguments, and its return is ignored. - -=item eager() - -This B be called inside a C builder coderef. - -This marks the I stage as being I. An eager stage will start -running tests for nested stages if it finds itself with no tests of its own to -run before the nested stage can finish loading. The idea here is to avoid -unused test slots when possible allowing for tests to complete sooner. - -=item default() - -This B be called inside a C builder coderef. - -This B be called only once across C stages in a given library. - -If multiple preload libraries are loaded then the I default set (based -on load order) will be the default, others will notbe honored. - -=item $stage_name = file_stage($test_file) - -This is optional. If defined this callback will have a chance to look at all -files that are going to be run and assign them a stage. This may return undef -or an empty list if it does not have a stage to assign. - -If multiple preload libraries define file_stage callbacks they will be called -in order, the first one to return a stage name will win. - -If no file_stage callbacks provide a stage for a file then any harness -directives declaring a stage will be honored. If no stage is ever assigned then -the test will be run int he default stage. - -=item pre_fork sub { ... } - -This B be called inside a C builder coderef. - -Add a callback to be run just before the preload-stage process forks to run the -test. Note that any state changes here can effect future tests to be run. - -=item post_fork sub { ... } - -This B be called inside a C builder coderef. - -Add a callback to be run just after the preload-stage process forks to run the -test. This is run as early as possible, things like C<$0> may not be set -properly yet. - -=item pre_launch sub { ... } - -This B be called inside a C builder coderef. - -Add a callback to be run just before control of the test process is turned over -to the test file itself. This is run as late as possible, so things like C<$0> -should be set properly. - -=back - -=head1 META-OBJECT - -This class is also the meta-object used to construct a preload library. The -methods are left undocumented as this is an implementation detail and you are -not intended to directly use this object. - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Runner/Preload/Stage.pm b/lib/Test2/Harness/Runner/Preload/Stage.pm index abba7a828..f75038058 100644 --- a/lib/Test2/Harness/Runner/Preload/Stage.pm +++ b/lib/Test2/Harness/Runner/Preload/Stage.pm @@ -2,158 +2,12 @@ package Test2::Harness::Runner::Preload::Stage; use strict; use warnings; -our $VERSION = '1.000152'; +our $VERSION = '2.000000'; -use Carp qw/croak/; +use Carp qw/cluck/; -use Test2::Harness::Util::HashBase qw{ - {+FRAME} //= [caller(1)]; - - croak "'name' is a required attribute" unless $self->{+NAME}; - - croak "Stage name 'base' is reserved, pick another name" if $self->{+NAME} eq 'base'; - croak "Stage name 'NOPRELOAD' is reserved, pick another name" if $self->{+NAME} eq 'NOPRELOAD'; - - $self->{+CHILDREN} //= []; - - $self->{+PRE_FORK_CALLBACKS} //= []; - $self->{+POST_FORK_CALLBACKS} //= []; - $self->{+PRE_LAUNCH_CALLBACKS} //= []; - - $self->{+LOAD_SEQUENCE} //= []; - $self->{+WATCHES} //= {}; -} - -sub watch { - my $self = shift; - my ($file, $callback) = @_; - croak "The first argument must be a file" unless $file && -f $file; - croak "The callback argument is required" unless $callback && ref($callback) eq 'CODE'; - croak "There is already a watch on file '$file'" if $self->{+WATCHES}->{$file}; - - $self->{+WATCHES}->{$file} = $callback; - return; -} - -sub all_children { - my $self = shift; - - my @out = @{$self->{+CHILDREN}}; - - for (my $i = 0; $i < @out; $i++) { - my $it = $out[$i]; - push @out => @{$it->children}; - } - - return \@out; -} - -sub add_child { - my $self = shift; - my ($stage) = @_; - push @{$self->{+CHILDREN}} => $stage; -} - -sub add_pre_fork_callback { - my $self = shift; - my ($cb) = @_; - croak "Callback must be a coderef" unless ref($cb) eq 'CODE'; - push @{$self->{+PRE_FORK_CALLBACKS}} => $cb; -} - -sub add_post_fork_callback { - my $self = shift; - my ($cb) = @_; - croak "Callback must be a coderef" unless ref($cb) eq 'CODE'; - push @{$self->{+POST_FORK_CALLBACKS}} => $cb; -} - -sub add_pre_launch_callback { - my $self = shift; - my ($cb) = @_; - croak "Callback must be a coderef" unless ref($cb) eq 'CODE'; - push @{$self->{+PRE_LAUNCH_CALLBACKS}} => $cb; -} - -sub add_to_load_sequence { - my $self = shift; - - for my $item (@_) { - croak "Item '$item' is not a valid preload, must be a module name (scalar) or a coderef" - unless ref($item) eq 'CODE' || !ref($item); - - push @{$self->{+LOAD_SEQUENCE}} => $item; - } - - return @_; -} - -sub do_pre_fork { my $self = shift; $_->(@_) for @{$self->{+PRE_FORK_CALLBACKS}} } -sub do_post_fork { my $self = shift; $_->(@_) for @{$self->{+POST_FORK_CALLBACKS}} } -sub do_pre_launch { my $self = shift; $_->(@_) for @{$self->{+PRE_LAUNCH_CALLBACKS}} } +cluck "Test2::Harness::Runner::Preload::Stage is deprecated, use Test2::Harness::Preload::Stage instead (hint 'Runner::' has been removed)"; 1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Runner::Preload::Stage - Abstraction of a preload stage. - -=head1 DESCRIPTION - -This is an implementation detail. You are not intended to directly use/modify -instances of this class. See L for -documentation on how to write a custom preload library. - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Runner/Preloader.pm b/lib/Test2/Harness/Runner/Preloader.pm deleted file mode 100644 index 5bce0871b..000000000 --- a/lib/Test2/Harness/Runner/Preloader.pm +++ /dev/null @@ -1,665 +0,0 @@ -package Test2::Harness::Runner::Preloader; -use strict; -use warnings; - -our $VERSION = '1.000152'; - -use B(); -use Carp qw/confess croak/; -use Fcntl qw/LOCK_EX LOCK_UN/; -use Time::HiRes qw/time sleep/; -use Test2::Harness::Util qw/open_file file2mod mod2file lock_file unlock_file clean_path/; - -use Test2::Harness::Runner::Reloader; -use Test2::Harness::Runner::Preloader::Stage; - -use File::Spec(); -use List::Util qw/pairgrep/; - -use Test2::Harness::Util::HashBase( - qw{ - {+PRELOADS} //= []; - - $self->{+BELOW_THRESHOLD} //= 0; - - return if $self->{+BELOW_THRESHOLD}; - - $self->{+MONITOR} = 1 if $self->{+RELOAD}; - - my $need_depmap = $self->{+RELOAD} || $self->{+MONITOR} || $self->{+DUMP_DEPMAP}; - - if ($need_depmap) { - require Test2::Harness::Runner::DepTracer; - $self->{+DTRACE} //= Test2::Harness::Runner::DepTracer->new(); - } - - if ($self->{+MONITOR} || $self->{+RELOAD}) { - $self->{+BLACKLIST} //= {}; - $self->{+BLACKLIST_FILE} //= File::Spec->catfile($self->{+DIR}, 'BLACKLIST'); - } - - $self->{+RELOADER} = Test2::Harness::Runner::Reloader->new( - stat_min_gap => 2, - notify_cb => sub { $self->_reload_cb_notify(@_) }, - find_loaded_cb => sub { $self->_reload_cb_find_loaded(@_) }, - should_watch_cb => sub { $self->_reload_cb_should_watch(@_) }, - can_reload_cb => sub { $self->_reload_cb_can_reload(@_) }, - reload_cb => sub { $self->_reload_cb_reload(@_) }, - delete_symbol_cb => sub { $self->_reload_cb_delete_symbol(@_) }, - ); -} - -sub stage_check { - my $self = shift; - my ($stage) = @_; - - return 0 if $self->{+BELOW_THRESHOLD}; - - my $p = $self->{+STAGED} or return 0; - return 1 if $stage eq 'NOPRELOAD'; - return 1 if $p->stage_lookup->{$stage}; - return 0; -} - -sub task_stage { - my $self = shift; - my ($file, $wants) = @_; - - $wants //= ""; - - return 'default' if $self->{+BELOW_THRESHOLD}; - return 'default' unless $self->{+STAGED}; - - return $wants if $wants && $self->stage_check($wants); - - my $stage = $self->{+STAGED}->file_stage($file) // $self->{+STAGED}->default_stage; - - return $stage; -} - -sub preload { - my $self = shift; - - croak "Already preloaded" if $self->{+DONE}; - - return 'default' if $self->{+BELOW_THRESHOLD}; - - my $preloads = $self->{+PRELOADS} or return 'default'; - return 'default' unless @$preloads; - - require Test2::API; - Test2::API::test2_start_preload(); - - # Not loading blacklist yet because any preloads in this list need to - # happen regardless of the blacklist. - if ($self->{+MONITOR} || $self->{+DTRACE}) { - $self->_monitor_preload($preloads); - } - else { - $self->_preload($preloads); - } - - $self->{+DONE} = 1; -} - -sub preload_stages { - my $self = shift; - return 'default' unless $self->{+STAGED}; - return $self->_preload_stages('NOPRELOAD', @{$self->{+STAGED}->stage_list}); -} - -sub _preload_stages { - my $self = shift; - my @stages = @_; - - my $name = 'base'; - my @procs; - - while (my $stage = shift @stages) { - $stage = $self->{+STAGED}->stage_lookup->{$stage} unless ref $stage || $stage eq 'NOPRELOAD'; - - my $proc = $self->launch_stage($stage); - - if ($proc) { - push @procs => $proc; - next; - } - - # We are in the stage now, reset these - if (ref $stage) { - $name = $stage->name; - @procs = (); - @stages = @{$stage->children}; - } - else { # NOPRELOAD - $name = $stage; - @procs = (); - @stages = (); - } - - $self->start_stage($stage); - } - - return($name, @procs); -} - -sub launch_stage { - my $self = shift; - my ($stage) = @_; - - $stage = $self->{+STAGED}->stage_lookup->{$stage} unless ref $stage || $stage eq 'NOPRELOAD'; - - my $name = ref($stage) ? $stage->name : $stage; - - my $pid = fork(); - - return Test2::Harness::Runner::Preloader::Stage->new( - pid => $pid, - name => $name, - ) if $pid; - - $0 .= "-$name"; - $ENV{T2_HARNESS_STAGE} = $name; - - return; -} - -sub start_stage { - my $self = shift; - my ($stage) = @_; - - if ($self->{+STAGED}) { - if ($stage && !ref($stage)) { - $stage = $self->{+STAGED}->stage_lookup->{$stage}; - } - } - else { - $stage = undef; - } - - $self->{+STAGE} = $stage; - - $self->load_blacklist if $self->{+MONITOR}; - - # Localize these in case something we preload tries to modify them. - local $SIG{INT} = $SIG{INT}; - local $SIG{HUP} = $SIG{HUP}; - local $SIG{TERM} = $SIG{TERM}; - - my $preloads = $stage ? $stage->load_sequence : []; - - my $meth = $self->{+MONITOR} || $self->{+DTRACE} ? '_monitor_preload' : '_preload'; - - $self->$meth($preloads, $stage->watches) if $preloads && @$preloads; - - $self->_monitor() if $self->{+MONITOR}; -} - -sub get_stage_callback { - my $self = shift; - my ($name) = @_; - - my $stage = $self->{+STAGE} or return undef; - return undef unless ref $stage; - return $stage->$name; -} - -sub _monitor_preload { - my $self = shift; - my ($preloads, $watch) = @_; - - my $block = {%{$self->blacklist}}; - my $dtrace = $self->dtrace; - - $dtrace->start; - $self->_preload($preloads, $block, $dtrace->my_require); - $dtrace->add_callbacks(%$watch) if $watch; - $dtrace->stop; - - return; -} - -sub _preload { - my $self = shift; - my ($preloads, $block, $require_sub) = @_; - - $block //= {}; - - my %seen; - for my $mod (@$preloads) { - next if $seen{$mod}++; - - if (ref($mod) eq 'CODE') { - next if eval { $mod->($block, $require_sub); 1 }; - $self->{+MONITOR} ? warn $@ : die $@; - next; - } - - next if $block && $block->{$mod}; - - next if eval { $self->_preload_module($mod, $block, $require_sub); 1 }; - $self->{+MONITOR} ? warn $@ : die $@; - } - - return; -} - -sub _preload_module { - my $self = shift; - my ($mod, $block, $require_sub) = @_; - - my $file = mod2file($mod); - - $require_sub ? $require_sub->($file) : require $file; - - return unless $mod->can('TEST2_HARNESS_PRELOAD'); - - die "You cannot load a Test2::Harness::Runner::Preload module from within another" if $self->{+DONE}; - - $self->{+STAGED} //= do { - require Test2::Harness::Runner::Preload; - Test2::Harness::Runner::Preload->new(); - }; - - $self->{+STAGED}->merge($mod->TEST2_HARNESS_PRELOAD); - - return; -} - -sub eager_stages { - my $self = shift; - - return unless $self->{+STAGED}; - return $self->{+STAGED}->eager_stages; -} - -sub load_blacklist { - my $self = shift; - - my $bfile = $self->{+BLACKLIST_FILE}; - my $blacklist = $self->{+BLACKLIST}; - - return unless -f $bfile; - - my $fh = open_file($bfile, '<'); - while(my $pkg = <$fh>) { - chomp($pkg); - $blacklist->{$pkg} = 1; - } -} - -sub _lock_blacklist { - my $self = shift; - - return $self->{+BLACKLIST_LOCK} if $self->{+BLACKLIST_LOCK}; - - my $bl = lock_file($self->{+BLACKLIST_FILE}, '>>'); - seek($bl,2,0); - - return $self->{+BLACKLIST_LOCK} = $bl; -} - -sub _unlock_blacklist { - my $self = shift; - - my $bl = delete $self->{+BLACKLIST_LOCK} or return; - - $bl->flush; - unlock_file($bl); - close($bl); - - return; -} - -sub _notify { - my $self = shift; - for my $msg (@_) { - print "$$ $0 - $msg\n"; - } -} - -sub _reload_cb_notify { - my $self = shift; - my ($type, $info) = @_; - - return $self->_notify("Runner detected a change in one or more preloaded modules...") - if $type eq 'changes_detected'; - - return $self->_notify("Runner detected changes in file '$info'...") - if $type eq 'file_changed'; - - return $self->_notify("Runner attempting to reload '$info->{file}' in place...") - if $type eq 'reload_inplace'; - - return $self->_notify( - "Runner failed to reload '$info->{file}' in place...", - map { split /\n/, $_ } grep { $_ } @{$info->{warnings} // []}, $info->{error}, - ) if $type eq 'reload_fail'; - - require Data::Dumper; - local $Data::Dumper::Sortkeys = 1; - local $Data::Dumper::Maxdepth = 2; - return $self->_notify("Runner notification $type: " . (ref($info) ? Data::Dumper::Dumper($info) : $info) . "..."); -} - -sub _reload_cb_find_loaded { keys %{$_[0]->dtrace->loaded} } - -sub _reload_cb_should_watch { - my $self = shift; - my ($reloader, $rel, $abs) = @_; - - my $dirs = $self->{+RESTRICT_RELOAD}; - return 1 unless $dirs && @$dirs; - - for my $dir (@$dirs) { - return 1 if 0 == index($abs, $dir); - } - - return 0; -} - -sub _reload_cb_can_reload { - my $self = shift; - my %params = @_; - - my $mod = $params{module}; - my $file = $params{file}; - - return (0, reason => 'File is a yath preload module') if $mod->can('TEST2_HARNESS_PRELOAD'); - - if (my $cb = $self->get_stage_callback('reload_inplace_check')) { - my ($res, %fields) = $cb->(module => $mod, file => $file); - return ($res, %fields) if defined $res; - } - - return (1) unless $mod->can('import'); - - return (0, reason => 'File is an importer') if $mod->can('IMPORTER_MENU'); - - { - no strict 'refs'; - return (0, reason => 'File is an importer') if @{"$mod\::EXPORT"}; - return (0, reason => 'File is an importer') if @{"$mod\::EXPORT_OK"}; - } - - return (1); -} - -sub find_churn { - my $self = shift; - my ($file) = @_; - - # When a file is saved to disk it seems it can vanish temporarily. Use this loop to wait for it... - my ($fh, $ok, $error); - for (1 .. 50) { - local $@; - $ok = eval { $fh = open_file($file) }; - $error = "LOOP $_: $@"; - last if $ok; - sleep 0.2; - } - - die $error // "Unknown error opening file '$file'" unless $fh; - - my $active = 0; - my @out; - - my $line_no = 0; - while (my $line = <$fh>) { - $line_no++; - - if ($active) { - if ($line =~ m/^\s*#\s*HARNESS-CHURN-STOP\s*$/) { - push @{$out[-1]} => $line_no; - $active = 0; - next; - } - else { - $out[-1][-1] .= $line; - next; - } - } - - if ($line =~ m/^\s*#\s*HARNESS-CHURN-START\s*$/) { - $active = 1; - push @out => [$line_no, '']; - } - } - - return @out; -} - -sub _reload_cb_reload { - my $self = shift; - my %params = @_; - - my ($file, $rel, $mod) = @params{qw/file relative module/}; - - my $callbacks; - if (my $dtrace = $self->dtrace) { - $callbacks = $dtrace->callbacks; - } - $callbacks //= {}; - - if (my $cb = $callbacks->{$file} // $callbacks->{$rel}) { - $self->_notify("Changed file '$rel' has a reload callback, executing it instead of regular reloading..."); - my $ret = $cb->(); - return (1, callback_return => $ret); - } - - if (my @churn = $self->find_churn($file)) { - $self->_notify("Changed file '$rel' contains churn sections, running them instead of a full reload..."); - - for my $churn (@churn) { - my ($start, $code, $end) = @$churn; - my $sline = $start + 1; - if (eval "package $mod;\nuse strict;\nuse warnings;\nno warnings 'redefine';\n#line $sline $file\n$code\n ;1;") { - $self->_notify("Success reloading churn block ($file lines $start -> $end)"); - } - else { - $self->_notify("Error reloading churn block ($file lines $start -> $end): $@"); - } - } - - return (1); - } - - return (0, reason => 'reloading disabled') unless $self->{+RELOAD}; - - return undef; -} - -sub _reload_cb_delete_symbol { - my $self = shift; - my %params = @_; - - my $sym = $params{symbol}; - my $mod = $params{module}; - my $file = $params{file}; - - # Make sure the changed file and the file that defined the sub are the same. - my $cb = $self->get_stage_callback('reload_remove_check') or return 0; - my $sub = $mod->can($sym) or return 0; - my $cobj = B::svref_2object($sub) or return 0; - my $subfile = $cobj->FILE or return 0; - - my $res = $cb->( - mod => $mod, - sym => $sym, - sub => $sub, - from_file => -f $subfile ? clean_path($subfile) : $subfile, - reload_file => -f $file ? clean_path($file) : $file, - ); - - # 0 means do not skip, so if the cb returned true we do not skip - return 0 if $res; - return 1; -} - -sub _monitor { - my $self = shift; - - if ($self->{+MONITORED} && $self->{+MONITORED}->[0] == $$) { - die "Monitor already starated\n" . "\n=======\n$0\n" . Carp::longmess() . "\n=====\n" . $self->{+MONITORED}->[1] . "\n" . $self->{+MONITORED}->[2] . "\n=======\n"; - } - - $self->{+MONITORED} = [$$, $0, Carp::longmess()]; - - my $reloader = $self->{+RELOADER}; - $reloader->reset(); - $reloader->refresh(); - - return $self->{+MONITORED}; -} - -sub check { - my $self = shift; - my ($state) = @_; - - return 1 if $self->{+CHANGED}; - - return 0 unless $self->{+MONITOR}; - - my $dtrace = $self->dtrace; - $dtrace->start if $self->{+RELOAD}; - - my $results = $self->{+RELOADER}->reload_changes(); - - $dtrace->stop if $self->{+RELOAD}; - - my (@todo, @fails); - for my $item (values %$results) { - my $stage = $self->{+STAGE} ? $self->{+STAGE}->name : 'default'; - $state->reload($stage => $item); - my $rel = $item->{reloaded}; - - next if $rel; # Reload success - - if (defined $rel) { # Not reloaded, but no error - push @todo => $item; - next; - } - } - - unless (@todo) { - $self->{+RELOADER}->refresh(); - return 0; - } - - $self->{+CHANGED} = 1; - $self->_notify("blacklisting changed files and reloading stage..."); - - my $bl = $self->_lock_blacklist(); - - my $dep_map = $self->dtrace->dep_map; - - my %CNI = reverse pairgrep { $b } %INC; - - my %seen; - while (@todo) { - my $item = shift @todo; - my $ref = ref($item); - - my ($mod, $abs, $rel); - if ($ref eq 'HASH') { - ($mod, $abs, $rel) = @{$item}{qw/module file relative/}; - } - elsif ($ref eq 'ARRAY') { - ($mod, $abs) = @$item; - $rel = $CNI{$abs} || $abs; - } - else { - die "Invalid ref type: $ref"; - } - - next if $seen{$abs}++; - next if $mod->can('TEST2_HARNESS_PRELOAD'); - $self->_notify("Blacklisting $mod..."); - print $bl "$mod\n"; - my $next = $dep_map->{$abs} or next; - push @todo => @$next; - } - - $self->_unlock_blacklist(); - - return 1; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Runner::Preloader - Preload logic. - -=head1 DESCRIPTION - -This module is responsible for preloading libraries before running tests. This -entire module is considered an "Implementation Detail". Please do not rely on -it always staying the same, or even existing in the future. Do not use this -directly. - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut - diff --git a/lib/Test2/Harness/Runner/Preloader/Stage.pm b/lib/Test2/Harness/Runner/Preloader/Stage.pm deleted file mode 100644 index 3559eabad..000000000 --- a/lib/Test2/Harness/Runner/Preloader/Stage.pm +++ /dev/null @@ -1,62 +0,0 @@ -package Test2::Harness::Runner::Preloader::Stage; -use strict; -use warnings; - -our $VERSION = '1.000152'; - -use parent 'Test2::Harness::IPC::Process'; -use Test2::Harness::Util::HashBase qw{ {+CATEGORY} //= 'stage' } - -1; - -__END__ - - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Runner::Preloader::Stage - Representation of a persistent stage process. - -=head1 DESCRIPTION - -This module is responsible for preloading libraries for a specific stage before -running tests. This entire module is considered an "Implementation Detail". -Please do not rely on it always staying the same, or even existing in the -future. Do not use this directly. - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Runner/Preloading.pm b/lib/Test2/Harness/Runner/Preloading.pm new file mode 100644 index 000000000..2f8f37e8c --- /dev/null +++ b/lib/Test2/Harness/Runner/Preloading.pm @@ -0,0 +1,196 @@ +package Test2::Harness::Runner::Preloading; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp qw/croak confess/; +use Scalar::Util qw/blessed/; + +use Test2::Util qw/IS_WIN32/; + +use Test2::Harness::Util qw/parse_exit mod2file/; +use Test2::Harness::IPC::Util qw/start_process/; +use Test2::Harness::Util::JSON qw/encode_json/; + +use Test2::Harness::Preload(); +use Test2::Harness::TestSettings; +use Test2::Harness::Runner::Preloading::Stage; + +use parent 'Test2::Harness::Runner'; +use Test2::Harness::Util::HashBase qw{ + stages + SUPER::init(); + + $self->{+STAGES} = {}; + + $self->{+PRELOAD_RETRY_DELAY} //= 5; +} + +sub set_stage_up { + my $self = shift; + my ($stage, $pid, $con) = @_; + + my $stage_data = $self->{+STAGES}->{$stage} // die "Invalid stage '$stage'"; + $stage_data->{ready} = {pid => $pid, con => $con}; + + return $pid; +} + +sub set_stage_down { + my $self = shift; + my ($stage, $pid) = @_; + + my $stage_data = $self->{+STAGES}->{$stage} // die "Invalid stage '$stage'"; + my $ready = $stage_data->{ready} // die "Stage not ready '$stage'"; + + if ($pid && $ready->{pid}) { + # It is possible we got the 'down' after a new 'up' + if ($ready->{pid} == $pid) { + delete $stage_data->{ready}; + } + } + else { + delete $stage_data->{ready}; + } + + return 1; +} + +sub stage_sets { + my $self = shift; + + my $stages = $self->{+STAGES}; + + my %sets; + + for my $stage (keys %$stages) { + my $sdata = $stages->{$stage}; + my $ready = $sdata->{ready} or next; + if (ref($ready)) { + next unless $ready->{con}; + next unless $ready->{pid}; + } + + $sets{$stage} = $stage; + $sets{$_} //= $stage for @{$sdata->{can_run} // []}; + } + + return [ map { [$_ => $sets{$_}] } keys %sets ]; +} + +sub DESTROY { shift->terminate } + +sub terminate { + my $self = shift; + + $self->SUPER::terminate(@_); + + kill('TERM', grep { $_ } map { $_->{ready}->{pid} } values %{$self->{+STAGES}}); +} + +sub kill { + my $self = shift; + $self->terminate; +} + +sub job_stage { + my $self = shift; + my ($job, $stage_request) = @_; + + return 'NONE' unless $self->{+PRELOADS} && @{$self->{+PRELOADS}}; + + for my $s ($stage_request, $self->default_stage, 'BASE') { + next unless $s; + next unless $self->{+STAGES}->{$s}; + return $s; + } + + confess "No valid stages!"; +} + +sub start { + my $self = shift; + my ($scheduler, $ipc) = @_; + + my $ts = $self->{+TEST_SETTINGS}; + + $self->{+STAGES}->{NONE} = {ready => 1, can_run => []}; + + my $preloads = $self->{+PRELOADS} or return; + return unless @$preloads; + + $self->start_base_stage($scheduler, $ipc); +} + +sub start_base_stage { + my $self = shift; + my ($scheduler, $ipc, $last_launch, $last_exit, $exit_code) = @_; + + print "Launching 'BASE' stage.\n"; + + my $pid = Test2::Harness::Runner::Preloading::Stage->launch( + name => 'BASE', + test_settings => $self->{+TEST_SETTINGS}, + ipc_info => $ipc->[0]->callback, + preloads => $self->preloads, + retry_delay => $self->{+PRELOAD_RETRY_DELAY}, + last_launch => $last_launch, + last_exit => $last_exit, + last_exit_code => $exit_code, + reloader => $self->{+RELOADER}, + restrict_reload => $self->{+RESTRICT_RELOAD}, + root_pid => $$, + ); + + my $launched = time; + $scheduler->register_child( + $pid => sub { + my %params = @_; + + my $exit = $params{exit}; + my $scheduler = $params{scheduler}; + + my $x = parse_exit($exit); + print "Stage 'BASE' exited(sig: $x->{sig}, code: $x->{err}).\n"; + + return if $scheduler->terminated || $scheduler->runner->terminated; + + $scheduler->runner->start_base_stage($scheduler, $ipc, $launched, time, $x->{err}); + }, + ); +} + +sub launch_job { + my $self = shift; + my ($stage, $run, $job) = @_; + + my $job_launch_data = $self->job_launch_data($run, $job); + my $ts = $job_launch_data->{test_settings}; + + my $can_fork = 1; + $can_fork &&= $stage ne 'NONE'; + $can_fork &&= $ts->use_fork; + $can_fork &&= $ts->use_preload; + + return $self->SUPER::launch_job('NONE', $run, $job) unless $can_fork; + + my $stage_data = $self->{+STAGES}->{$stage} or confess "Invalid stage: '$stage'"; + + my $res = $stage_data->{ready}->{con}->send_and_get(launch_job => $job_launch_data); + return 1 if $res->success; +} + +1; diff --git a/lib/Test2/Harness/Runner/Preloading/Stage.pm b/lib/Test2/Harness/Runner/Preloading/Stage.pm new file mode 100644 index 000000000..fe9fb3342 --- /dev/null +++ b/lib/Test2/Harness/Runner/Preloading/Stage.pm @@ -0,0 +1,497 @@ +package Test2::Harness::Runner::Preloading::Stage; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +my %ORIG_SIG; +BEGIN { %ORIG_SIG = %SIG } + +use goto::file(); +use Scope::Guard; + +use POSIX qw/:sys_wait_h/; + +use Test2::Harness::Util qw/mod2file parse_exit/; +use Test2::Harness::IPC::Util qw/start_process ipc_connect ipc_warn ipc_loop pid_is_running/; +use Test2::Harness::Util::JSON qw/decode_json encode_json/; + +use Test2::Harness::Collector::Preloaded; + +use Test2::Harness::Util::HashBase qw{ + autoflush(1); + STDERR->autoflush(1); + + my $ok = eval { + my ($json) = @ARGV; + + my $self = $class->new(decode_json($json)); + + my $got = $self->start(); + $EXIT = $got->{exit} if exists $got->{exit}; + + if (my $test = $got->{run_test}) { + $EXIT = Test2::Harness::Collector::Preloaded->collect(data => $test, orig_sig => \%ORIG_SIG, stage => $self, root_pid => $self->{+ROOT_PID}); + } + + 1; + }; + $ERROR = $@ unless $ok; + } + else { + $ERROR //= "Invalid action '$do'"; + } +} + +sub launch { + my $class = shift; + my %params = @_; + + $params{parent} //= $$; + + my $ts = $params{test_settings}; + + my $pkg = __PACKAGE__; + + my %seen; + my $pid = start_process( + $^X, # Call current perl + (map { ("-I$_") } grep { -d $_ && !$seen{$_}++ } @INC), # Use the dev libs specified + (map { ("-I$_") } grep { -d $_ && !$seen{$_}++ } @{$ts->includes}), # Use the test libs + "-m${class}=start", # Load Stage + '-e' => "\$${pkg}\::ERROR ? die \$${pkg}\::ERROR : exit(\$${pkg}\::EXIT // 255)", # Run it. + encode_json(\%params), # json data for job + ); + + return $pid; +} + +sub start { + my $self = shift; + + $self->{+PID} = $$; + + $0 = "yath-runner-$self->{+NAME}"; + + $self->check_delay( + 'BASE', + $self->{+LAST_EXIT_CODE} ? $self->{+LAST_EXIT} : $self->{+LAST_LAUNCH}, + ); + + my $pid = $$; + my ($ipc, $con) = ipc_connect($self->{+IPC_INFO}); + + $self->do_preload($ipc, $con); + + while (1) { + unless ($$ == $pid) { + $con = undef; + $ipc = undef; + ($ipc, $con) = ipc_connect($self->{+IPC_INFO}); + } + + my $out = $self->run_stage($ipc, $con); + return $out unless $out && $out->{run_stage}; + } +} + +sub check_delay { + my $self = shift; + my ($name, $base_time) = @_; + + return unless $base_time; + my $delta = time - $base_time; + + return 0 unless $delta < $self->{+RETRY_DELAY}; + my $wait = $self->{+RETRY_DELAY} - $delta; + + $0 = "yath-runner-$name-DELAYED"; + print "Stage '$name' reload attempt came too soon, waiting $wait seconds before reloading...\n"; + sleep($wait); +} + +sub init { + my $self = shift; + $self->{+TREE} //= ''; + $self->{+RETRY_DELAY} //= 5; +} + +sub do_preload { + my $self = shift; + my ($ipc, $con) = @_; + + my $preloads = $self->{+PRELOADS}; + + my $preload; + + require Test2::API; + Test2::API::test2_start_preload(); + + for my $mod (@$preloads) { + require(mod2file($mod)); + next unless $mod->can('TEST2_HARNESS_PRELOAD'); + + $preload //= Test2::Harness::Preload->new(); + $preload->merge($mod->TEST2_HARNESS_PRELOAD); + } + + my $stage_data = {BASE => {can_run => []}}; + + if ($preload) { + my $eager = $preload->eager_stages; + my $lookup = $preload->stage_lookup; + + for my $stage (keys %$lookup) { + $stage_data->{$stage} = { + can_run => $eager->{$stage} // [], + }; + } + } + + $con->send_and_get(set_stage_data => $stage_data); + + $self->start_stage($self->{+PARENT}, 'BASE'); + + if ($preload) { + for my $stage (@{$preload->stage_list}) { + last if $self->fork_stage($stage); + } + } + + return; +} + +sub fork_stage { + my $self = shift; + my ($stage) = @_; + + my $parent = $$; + my $pid = fork // die "Could not fork: $!"; + + if ($pid) { + $self->{+CHILDREN}->{$pid} = [time, $stage]; + return 0; + } + + $self->{+PID} = $$; + $self->{+PARENT} = $parent; + $self->{+CHILDREN} = {}; + $self->start_stage($parent, $stage); + + for my $child (@{$stage->children || []}) { + last if $self->fork_stage($child); + } + + return 1; +} + +sub check_children { + my $self = shift; + + local ($?, $!); + + while (1) { + my $pid = waitpid(-1, WNOHANG); + my $exit = $?; + + last if $pid < 1; + + my $set = delete $self->{+CHILDREN}->{$pid} or die "Reaped untracked process!"; + my ($time, $stage) = @$set; + + print "Stage $stage->{name} ended, restarting...\n"; + + if ($self->fork_stage($stage)) { + $self->check_delay($stage->{name}, $time); + return 1; + } + } + + return 0; +} + +sub DESTROY { + my $self = shift; + + return unless $self->{+PID} && $self->{+PID} == $$; + + kill('TERM', keys %{$self->{+CHILDREN}}); +} + +sub start_stage { + my $self = shift; + my ($parent, $stage) = @_; + + $self->{+PARENT} = $parent; + + my $stage_ref = ref($stage); + my ($name); + if ($stage_ref) { + $name = $stage->name; + } + else { + $name = $stage; + } + + $self->{+STAGE} = $stage; + $self->{+NAME} = $name; + my $tree = $self->{+TREE} = $self->{+TREE} ? "$self->{+TREE}-$name" : $name; + $0 = "yath-runner-$tree"; + + $ENV{T2_HARNESS_STAGE} = $name; + + return unless $stage_ref; + + warn "Blacklist, custom require"; + + for my $item (@{$stage->load_sequence}) { + my $type = ref($item); + if ($type eq 'CODE') { + $item->(); + } + else { + require(mod2file($item)); + die "Cannot load one custom preloader within another" if $item->can('TEST2_HARNESS_PRELOAD'); + } + } +} + +sub terminate { + my $self = shift; + my ($reason) = @_; + $self->{+TERMINATED} = $reason; +} + +sub run_stage { + my $self = shift; + my ($ipc, $con) = @_; + + my $pid = $$; + + $con->send_and_get(set_stage_up => {stage => $self->{+NAME}, pid => $pid}); + print "Stage '$self->{+NAME}' is up.\n"; + + my $guard = Scope::Guard->new(sub { + return unless $pid == $$; + $con->send_and_get(set_stage_down => {stage => $self->{+NAME}, pid => $pid}, do_not_respond => 1) if $con && $con->active; + print "Stage '$self->{+NAME}' is down.\n"; + }); + + my $reloader; + if (my $reloader_class = $self->{+RELOADER}) { + require(mod2file($reloader_class)); + $reloader = $reloader_class->new(restrict => $self->{+RESTRICT_RELOAD}, stage => $self->{+STAGE}); + + $reloader->set_active(); + $reloader->start(); + } + + my $ios = IO::Select->new(); + $ios->add($_) for $ipc->handles_for_select; + + my $exit = 0; + my $run_test; + my $run_stage; + + ipc_loop( +# debug => 1, + + ipcs => [$ipc], + wait_time => 0.2, + + quiet_signals => sub { $self->terminate("SIG" . $_[0]) }, + + iteration_start => sub { + # Check for parent exit + exit(0) unless pid_is_running($self->{+PARENT}); + + # check reload + if ($reloader && $reloader->check_reload()) { + $exit = 0; + + no warnings 'exiting'; + last IPC_LOOP; + } + + # Check kids + if ($self->check_children()) { + $run_stage = 1; + + no warnings 'exiting'; + last IPC_LOOP; + } + }, + + end_check => sub { + return 1 if $run_test; + return 1 if $self->{+TERMINATED}; + return 0; + }, + + handle_request => sub { + my $req = shift; + + my $pid = fork // die "Could not fork: $!"; + + if ($pid) { + local $? = 0; + my $check = waitpid($pid, 0); + if ($check == $pid && !$?) { + return Test2::Harness::Instance::Response->new( + api => {success => 1}, + response_id => $req->request_id, + response => 1, + ); + } + else { + my $x = parse_exit($?); + return Test2::Harness::Instance::Response->new( + api => {success => 0, error => "$pid vs $check. exit val: $x->{err} signal: $x->{sig}."}, + response_id => $req->request_id, + response => 0, + ); + } + } + + $run_test = $req->args; + + no warnings 'exiting'; + last IPC_LOOP; + }, + + # Intentionally do nothing. + handle_message => sub { }, + ); + + return {run_stage => $run_stage} if $run_stage; + return {run_test => $run_test} if $run_test; + return {exit => $exit}; +} + +for my $meth (qw/do_pre_fork do_post_fork do_pre_launch/) { + my $name = $meth; + my $sub = sub { + my $self = shift; + my $stage = $self->stage or return; + return unless ref($stage); + $stage->$name(@_); + }; + + no strict 'refs'; + *$meth = $sub; +} + +1; + +__END__ + my $ipc_map; + my $ios; + my $reset_ios = sub { + $ipc_map = {}; + $ios = IO::Select->new(); + for my $ipc (@{$self->{+IPC}}) { + for my $h ($ipc->handles_for_select) { + $ios->add($h); + $ipc_map->{$h} = $ipc; + } + } + }; + $reset_ios->(); + + my $last_ipc_count = 1; + my $last_health_check = 0; + my $advanced = 1; + while (1) { + print "LOOP: " . sprintf('%-02.4f', time) . "\n"; + $cb->() if $cb; + + if (time - $last_health_check > 4) { + $last_ipc_count = 0; + + for my $ipc (@{$self->{+IPC}}) { + next unless $ipc->active; + $ipc->health_check; + $last_ipc_count++ if $ipc->active; + } + + $last_health_check = time; + } + + my @ready; + while (1) { + $! = 0; + @ready = $ios->can_read($advanced ? 0 : $self->{+WAIT_TIME}); + last if @ready || $! == 0; + + # If the system call was interrupted it could mean a child process + # exited, or similar. Just break the loop so we can advance the + # scheduler which also reaps child processes. + last if $! == EINTR; + + warn((0 + $!) . ": $!"); + + $reset_ios->(); + last unless keys %$ipc_map; + } + + my %seen; + for my $h (@ready) { + my $ipc = $ipc_map->{$h} or next; + next if $seen{$ipc}++; + + while (my $req = $ipc->get_request) { + warn "FIXME: Remove these prints" unless $WARNED++; +# print "Request: " . encode_pretty_json($req) . "\n"; + my $res = $self->handle_request($req); +# print "Response: " . encode_pretty_json($res) . "\n"; + + next if $req->do_not_respond; + + eval { $ipc->send_response($req, $res); 1 } or ipc_warn(ipc_class => ref($ipc), error => $@, request => $req, response => $res); + } + } + + $advanced = $self->{+SCHEDULER}->advance(); + + # No IPC means nothing to do + last unless keys %$ipc_map; + last unless $last_ipc_count; + last if $self->{+TERMINATED}; + } + + diff --git a/lib/Test2/Harness/Runner/Resource.pm b/lib/Test2/Harness/Runner/Resource.pm deleted file mode 100644 index 81455162a..000000000 --- a/lib/Test2/Harness/Runner/Resource.pm +++ /dev/null @@ -1,597 +0,0 @@ -package Test2::Harness::Runner::Resource; -use strict; -use warnings; - -use Term::Table; -use Time::HiRes qw/time/; -use Test2::Util::Times qw/render_duration/; - -our $VERSION = '1.000152'; - -sub scope_global { 0 } -sub scope_host { 0 } -sub scope_run { 1 } - -sub setup {} - -sub new { - my $class = shift; - return bless({@_}, $class); -} - -sub tick { } - -sub refresh { } - -sub discharge { } - -sub sort_weight { - my $class = shift; - return 100 if $class->job_limiter; - return 50; -} - -sub job_limiter { 0 } - -sub job_limiter_max { } - -sub job_limiter_at_max { 0 } - -sub available { -1 } - -sub record { } - -sub assign { } - -sub release { } - -sub cleanup { } - -sub status_data {()} - -sub status_lines { - my $self = shift; - - my $data = $self->status_data || return; - return unless @$data; - - my $out = ""; - - for my $group (@$data) { - my $gout = "\n"; - $gout .= "**** $group->{title} ****\n\n" if defined $group->{title}; - - for my $table (@{$group->{tables} || []}) { - my $rows = $table->{rows}; - - if (my $format = $table->{format}) { - my $rows2 = []; - - for my $row (@$rows) { - my $row2 = []; - for (my $i = 0; $i < @$row; $i++) { - my $val = $row->[$i]; - my $fmt = $format->[$i]; - - $val = defined($val) ? render_duration($val) : '--' - if $fmt && $fmt eq 'duration'; - - push @$row2 => $val; - } - push @$rows2 => $row2; - } - - $rows = $rows2; - } - - next unless $rows && @$rows; - - my $tt = Term::Table->new( - header => $table->{header}, - rows => $rows, - - sanitize => 1, - collapse => 1, - auto_columns => 1, - - %{$table->{term_table_opts} || {}}, - ); - - $gout .= "** $table->{title} **\n" if defined $table->{title}; - $gout .= "$_\n" for $tt->render; - $gout .= "\n"; - } - - if ($group->{lines} && @{$group->{lines}}) { - $gout .= "$_\n" for @{$group->{lines}}; - $gout .= "\n"; - } - - $out .= $gout; - } - - return $out; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Runner::Resource - Base class for resource management classes - -=head1 DESCRIPTION - -Sometimes you have limited resources that must be shared/divided between tests -that run concurrently. Resource classes give you a way to leverage the IPC -system used by L to manage resource assignment and recovery. - -=head1 SYNOPSIS - -Here is a resource class that simply assigns an integer to each test. It would -be possible to re-use integers, but since there are infinite integers this -example is kept simple and just always grabs the next one. - - package Test2::Harness::Runner::Resource::Foo; - use strict; - use warnings; - - use parent 'Test2::Harness::Runner::Resource'; - - sub setup { - my $class = shift; # NOT AN INSTANCE - ... - } - - sub available { - my $self = shift; - my ($task) = @_; - - # There are an infinite amount of integers, so we always return true - return 1; - } - - sub assign { - my $self = shift; - my ($task, $state) = @_; - - # Next ID, do not record the state change yet! - my $id = 1 + ($self->{ID} //= 0); - - print "ASSIGN: $id = $task->{job_id}\n"; - - # 'record' should get whatever we need to record the resource, whatever you - # pass in will become the argument to the record() sub below. This may be a - # scalar, a hash, an array, etc. It will be serialized to JSON before - # record() sees it. - $state->{record} = $id; - - # Pass the resource into the test, this can be done as envronment variables - # and/or arguments to the test (@ARGV). - $state->{env_vars}->{FOO_ID} = $id; - push @{$state->{args}} => $id; - - # The return is ignored. - return; - } - - sub record { - my $self = shift; - my ($job_id, $record_arg_from_assign) = @_; - - # The ID from $state->{record}->{$pkg} in assign. - my $id = $record_arg_from_assign; - - # Update our internal state to reflect the new ID. - $self->{ID} = $id; - - # Add a mapping of what job ID gets what integer ID. - $self->{ID_TO_JOB_ID}->{$id} = $job_id; - $self->{JOB_ID_TO_ID}->{$job_id} = $id; - - print "RECORD: $id = $job_id\n"; - - # The return is ignored - } - - sub tick { - my $self = shift; - - # This is called by only 1 process at a time and gives you a way to do - # extra stuff at a regular interval without other processes trying to - # do the same work at the same time. - # For example, if a database is left in a dirty state after it is - # released, you can fire off a cleanup action here knowing no other - # process will run it at the same time. You can also be sure no record - # messages will be sent while this sub is running as the process it - # runs in has a lock. - - ... - } - - - sub release { - my $self = shift; - my ($job_id) = @_; - - # Clear the internal mapping, the integer ID is now free. Theoretically it - # can be reused, but this example is not that complex. - my $id = delete $self->{JOB_ID_TO_ID}->{$job_id}; - - # This is called for all tests that complete, even if they did not use - # this resource, so we return if the job_id is not applicable. - return unless defined $id; - - delete $self->{ID_TO_JOB_ID}->{$id}; - - print " FREE: $id = $job_id\n"; - - # The return is ignored - } - - sub cleanup { - my $self = shift; - - print "CLEANUP!\n"; - } - - 1; - -The print statements generated will look like this when running 2 tests concurrently: - - yath test -R Foo -j2 t/testA.t t/testB.t - [...] - (INTERNAL) ASSIGN: 1 = 4F7CF5F6-E43F-11EA-9199-24FCBF610F44 - (INTERNAL) RECORD: 1 = 4F7CF5F6-E43F-11EA-9199-24FCBF610F44 - (INTERNAL) ASSIGN: 2 = E19CD98C-E436-11EA-8469-8DF0BF610F44 - (INTERNAL) RECORD: 2 = E19CD98C-E436-11EA-8469-8DF0BF610F44 - (INTERNAL) FREE: 1 = 4F7CF5F6-E43F-11EA-9199-24FCBF610F44 - (INTERNAL) FREE: 2 = E19CD98C-E436-11EA-8469-8DF0BF610F44 - (INTERNAL) CLEANUP! - [...] - -Depending on the tests run the 'FREE' prints may be out of order. - -=head1 WORKFLOW - -=head2 HOW STATE IS MANAGED - -Depending on your preload configuration, yath may have several runners -launching tests. If a runner has nothing to do it will lock the queue and try -to find the next test that should be run. Only 1 of the runners will be in -control of the queue at any given time, but the control of the queue may pass -between runners. To manage this there is a mechanism to record messages that -allow each runner to maintain a copy of the current state. - -=head2 CHECK IF RESOURCES ARE AVAILABLE - -Each runner will have an instance of your resource class. When the runner is in -control of the queue, and wants to designate the next test to run, it will -check with the resource classes to make sure the correct resources are -available. To do that it will call C on each resource -instance. - -The C<$task> will contain the specification for the test, it is a hashref, and -you B modify it. The only key most people care about is the 'file' -key, which has the test file that will be run if resources are available. - -If resources are available, or if the specific file does not need the resource, -the C method should return true. If the file does need your -resource(s), and none are available, this should return false. If any resource -class returns false it means the test cannot be run yet and the runner will -look for another test to run. - -=head2 ASSIGN A RESOURCE - -If the runner has determined the test can be run, and all necessary resources -are available, it will then call C on all resource class -instances. At this time the resource class should decide what resource(s) to -assign to the class. - -B the C method B alter any internal state -on the resource class instance. State modification must wait for the -C method to be called. This is because the C method is only -called in one runner process, the C method call will happen in every -runner process to insure they all have the same internal state. - -The assign() sub should modify the C<$state> hash, which has 3 keys: - -=over 4 - -=item env_vars => {} - -Env vars to set for the test - -=item args => [] - -Arguments to pass to the test - -=item record => ... - -Data needed to record the state change for resource classes. Can be a scalar, -hashref, arrayref, etc. It will be serialized to JSON to be passed between -processes. - -=back - -=head2 RECORD A RESOURCE - -Once a resource is assigned, a message will be sent to all runner processes -B that says it should call -C on your resource class instance. Your resource -class instance must use this to update the state so that once done ALL -processes will have the proper internal state. - -The C<$record_val> is whatever you put into C<< $state->{record} >> in the -C method above. - -=head2 QUEUE MANAGEMENT IS UNLOCKED - -Once the above has been done, queue management will be unlocked. You can be -guarenteed that only one process will be run the C, and -C sequence at a time, and that they will be called in order, though -C may not be called if another resource was not available. If -C is called, you can be guarenteed that all processes, including the -one that called C will have their C called with the proper -argument B they try to manage the queue (which is the only place -resources are checked or assigned). - -=head2 RELEASE A RESOURCE - -Whenever a process that is using a resource exits, the runner that waits on -that process will I send an IPC message announcing that the job_id -has completed. Every time a job_id completes the C method -will be called on your resource class in all runner processes. This allows the -state to be updated to reflect the freed resource. - -You can be guarenteed that any process that locks the queue to run a new -test will eventually see the message. The message may come in during a loop -that is checking for resources, in which case the state will not reflect the -resource being available, however in such cases the loop will end and be -called again later with the message having been receieved. There will be no -deadlock due to a queue manager waiting for the message. - -There are no guarentees about what order resources will be released in. - -=head1 METHODS - -=over 4 - -=item $class->setup($settings) - -This will be called once before the runner forks or initialized per-process -instances. If you have any "setup once" tasks to initialize resources before -tests run this is a good place to do it. - -This runs immedietly after plugin setup() methods are called. - -B Do not rely on recording any global state here, the runner and -per-process instances may not be forked from the process that calls setup(). - -=item $res = $class->new(settings => $settings); - -A default new method, returns a blessed hashref with the settings key set to -the L instance. - -=item $val = $res->available(\%task) - -B - -B - -Returns a positive true value if the resource is available. - -Returns false if the resource is not available, but will be in the future (IE -in use by another test, but will be free when that test is done). - -Returns a negative value if the resource is not available and never will be. -This will cause any tests dependent on the resource to be skipped. - -The only key in C<\%task> hashref that most resources will care about is the -C<'file'> key, which contains the test file to be run. - -=item $res->assign(\%task, \%state) - -B - -B - -If the task does not need any resources you may simply return. - -If resources are needed you should deduce what resources to assign. - -You should put any data needed to update the internal state of your resource -instance in the C<< $state->{record} >> hash key. It B be serialized to -JSON before being used as an argument to C. - - $state->{record} = $id; - -If you do not set the 'record' key, or set it to undef, then the C -method will not be called. - -If your tests need to know what resources to use, you may set environment -variables and/or command line arguments to pass into the test (C<@ARGV>). - - $state->{env_vars}->{FOO_ID} = $id; - push @{$state->{args}} => $id; - -The C<\%state> hashref is used only by your instance, you are free to fully -replace the 'env_vars' and 'args' keys. They will eventually be merged into a -master state along with those of other resources, but this ref is exclusive to -you in this method. - -=item $inst->record($job_id, $record_arg_from_assign) - -B. - -This will be called in all processes so that your instance can update any -internal state. - -The C<$job_id> variable contains the id for the job to which the resource was -assigned. You should use this to record any internal state. The $job_id will be -passed to C when the job completes and no longer needs the resource. - -This is intended only for modifying internal state, you should not do anything -in this sub that will explode if it is also done in another process at the same -time with the same arguments. For example creating a database should not be -done here, multiple processes will fight to do the create. The creation, if -necessary should be done in C which will be called in only one -process. - -=item $inst->release($job_id) - -B. - -This will be called for every test job that completes, even if it did not use -this resource. If the job_id did not use the resource you may simply return, -otherwise update the internal state to reflect that the resource is no longer -in use. - -This is intended only for modifying internal state, you should not do anything -in this sub that will explode if it is also done in another process at the same -time with the same arguments. For example deleting a database should not be -done here, multiple processes will fight to do the delete. C is the -only method that will be run in a single process, so if a database needs to be -cleaned before it can be used you should clean it there. Any final cleanup -should be done in C which will only be called by one process at the -very end. - -=item $inst->cleanup() - -This will be called once by the parent runner process just before it exits. -This is your chance to do any final cleanup tasks such as deleting databases -that are no longer going to be used by tests as no more will be run. - -=item $inst->tick() - -This is called by only 1 process at a time and gives you a way to do extra -stuff at a regular interval without other processes trying to do the same work -at the same time. - -For example, if a database is left in a dirty state after it is released, you -can fire off a cleanup action here knowing no other process will run it at the -same time. You can also be sure no record messages will be sent while this sub -is running as the process it runs in has a lock. - -=item $inst->refresh() - -Called once before each resource-request loop. This is your chance to do things -between each set of requests for resources. - -=item $bool = $inst->job_limiter() - -True if your resource is intended as a job limiter (IE alternative to -specifying -jN at the command line). - -=item $int = $inst->job_limiter_max() - -Max number of jobs this will allow at the moment, if this resource is a job -limiter. - -=item $bool = $inst->job_limiter_at_max() - -True if the limiter has reached its maximum number of running jobs. This is -used to avoid a resource-allocation loop as an optimization. - -=item $number = $inst->sort_weight() - -Used to sort resources if you want them to be checked in a specific order. For -most resources this defaults to 50. For job_limiter resources this defaults to -100. Lower numbers are sorted to the front of the list, IE they are aquired -first, before other resources. - -Job slots are sorted later (100) so that we do not try to grab a job slot if -other resources are not available. - -Most of the time order will not matter, however with Shared job slots we have a -race with other test runs to get slots, and checking availability is enough to -consume a slot, even if other resources are not available. - -=item $string = $inst->status_lines() - -Get a (multi-line) string with status info for this resource. This is used to -populate the output for the C command. - -The default implementation will build a string from the data provided by the -C method. - -=item $arrayref = $inst->status_data() - -The default implementation returns an empty list. - -This should return status data that looks like this: - - return [ - { - title => "Resource Group Title", - tables => [ - { - header => \@columns, - rows => [ - \@row1, - \@row2, - ], - - # Optional fields - ################## - - # formatting for fields in rows - format => [undef, undef, 'duration', ...], - - # Title for the table - title => "Table Title", - - # Options to pass to Term::Table if/when it the data is used in Term::Table - term_table_opts => {...}, - }, - - # Any number of tables is ok - {...}, - ], - }, - - # Any number of groups is ok - {...}, - ]; - -Currently the only supported formats are 'default' (undef), and 'duration'. -Duration takes a stamp and tells you how much time has passed since the stamp. - -=back - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Runner/Resource/JobCount.pm b/lib/Test2/Harness/Runner/Resource/JobCount.pm deleted file mode 100644 index 1c8fb3f6d..000000000 --- a/lib/Test2/Harness/Runner/Resource/JobCount.pm +++ /dev/null @@ -1,168 +0,0 @@ -package Test2::Harness::Runner::Resource::JobCount; -use strict; -use warnings; - -our $VERSION = '1.000152'; - -use parent 'Test2::Harness::Runner::Resource'; -use Test2::Harness::Util::HashBase qw/init(); - return $self; -} - -sub init { - my $self = shift; - my $settings = $self->{+SETTINGS}; - $self->{+JOB_COUNT} //= $settings ? $settings->runner->job_count // 1 : 1; - $self->{+USED} //= {}; - $self->{+FREE} //= [1 .. $self->{+JOB_COUNT}]; -} - -sub job_limiter_max { - my $self = shift; - return $self->{+JOB_COUNT}; -} - -sub job_limiter_at_max { - my $self = shift; - return 0 if @{$self->{+FREE}}; - return 1; -} - -sub available { - my $self = shift; - my ($task) = @_; - - my $rmin = $self->settings->runner->slots_per_job; - my $tmin = $task->{min_slots} // 1; - my $tmax = $task->{max_slots} // $tmin; - - return -1 if $self->{+JOB_COUNT} < $tmin; - return -1 if $rmin < $tmin; - - my $concurrency = min(grep { $_ } $tmax, $rmin); - $concurrency ||= 1; - - return 1 if @{$self->{+FREE}} >= $concurrency; - return 0; -} - -sub assign { - my $self = shift; - my ($task, $state) = @_; - - my $rmin = $self->settings->runner->slots_per_job; - my $tmin = $task->{min_slots} // 1; - my $tmax = $task->{max_slots} // $tmin; - my $concurrency = min(grep { $_ } $tmax, $rmin); - $concurrency ||= 1; - - $state->{record} = { - count => $concurrency, - file => $task->{rel_file}, - stamp => time, - }; - - $state->{env_vars}->{T2_HARNESS_MY_JOB_CONCURRENCY} = $concurrency; -} - -sub record { - my $self = shift; - my ($job_id, $info) = @_; - - my $count = $info->{count}; - my @use = splice @{$self->{+FREE}}, 0, $count; - $info->{slots} = \@use; - - $self->{+USED}->{$job_id} = $info; -} - -sub release { - my $self = shift; - my ($job_id) = @_; - - # Could be a free with no used slot. - my $info = delete $self->{+USED}->{$job_id} or return; - my $slots = $info->{slots}; - - push @{$self->{+FREE}} => @$slots; -} - -sub status_data { - my $self = shift; - - my @rows; - - my $time = time; - - for my $info (sort { $a->{stamp} <=> $b->{stamp} } values %{$self->{+USED}}) { - my $count = @{$info->{slots} || []}; - push @rows => [$time - $info->{stamp}, $count, $info->{file}]; - } - - push @rows => [undef, scalar(@{$self->{+FREE}}), '** FREE **']; - - return [ - { - tables => [ - { - headers => [qw/Runtime Slots Name/], - format => ['duration'], - rows => \@rows, - }, - ], - }, - ], -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Runner::Resource::JobCount - limit the job count (-j) - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Runner/Resource/SharedJobSlots.pm b/lib/Test2/Harness/Runner/Resource/SharedJobSlots.pm deleted file mode 100644 index 68aca12dd..000000000 --- a/lib/Test2/Harness/Runner/Resource/SharedJobSlots.pm +++ /dev/null @@ -1,432 +0,0 @@ -package Test2::Harness::Runner::Resource::SharedJobSlots; -use strict; -use warnings; - -our $VERSION = '1.000152'; - -use YAML::Tiny; -use Test2::Harness::Runner::Resource::SharedJobSlots::State; -use Test2::Harness::Runner::Resource::SharedJobSlots::Config; - -use Time::HiRes qw/time/; -use List::Util qw/min/; -use Carp qw/confess/; - -use parent 'Test2::Harness::Runner::Resource'; -use Test2::Harness::Util::HashBase qw{ - init(); - return $self; -} - -sub init { - my $self = shift; - my $settings = $self->{+SETTINGS}; - - my $sconf = Test2::Harness::Runner::Resource::SharedJobSlots::Config->find(settings => $settings); - die "Could not find shared jobs config.\n" - unless $sconf; - - my $runner_id = $self->{+RUNNER_ID} //= $settings->runner->runner_id if $settings->check_prefix('runner'); - my $runner_pid = $self->{+RUNNER_PID} //= $Test2::Harness::Runner::RUNNER_PID // $App::Yath::Command::runner::RUNNER_PID; - - my $prefix = $settings->debug->procname_prefix // ''; - my $name = $settings->harness->project // ''; - - my $dir; - if (my $path = $settings->harness->config_file) { - if ($path =~ m{^(.*)/[^/]+$}) { - $dir = $1; - } - } - - $dir //= $settings->harness->cwd; - - unless ($name) { - $name = $dir; - $name =~ s{^.*/}{}; - } - - $name = "$prefix-$name" if $prefix; - - $self->{+JOB_LIMITER_MAX} = min(grep { $_ } $sconf->max_slots_per_run, $settings->runner->job_count); - - $self->{+STATE} = Test2::Harness::Runner::Resource::SharedJobSlots::State->new( - dir => $dir, - name => $name, - runner_id => $runner_id, - runner_pid => $runner_pid, - - state_umask => $sconf->state_umask, - state_file => $sconf->state_file, - algorithm => $sconf->algorithm, - max_slots => $sconf->max_slots, - max_slots_per_job => $sconf->max_slots_per_job, - max_slots_per_run => $sconf->max_slots_per_run, - min_slots_per_run => $sconf->min_slots_per_run, - default_slots_per_run => $sconf->default_slots_per_run, - default_slots_per_job => $sconf->default_slots_per_job, - - my_max_slots => min($self->settings->runner->job_count, $sconf->max_slots), - my_max_slots_per_job => min($self->settings->runner->slots_per_job, $sconf->max_slots_per_job), - ); - - $self->{+CONFIG} = $sconf; - - return; -} - -# Disable this short-circuit otherwise we may never queue a request! -sub job_limiter_at_max { 0 } - -sub refresh { $_[0]->{+STATE}->update_registration } - -sub _job_concurrency { - my $self = shift; - my ($task) = @_; - - my $rmax = $self->settings->runner->job_count; - my $jmax = $self->settings->runner->slots_per_job; - my $srmax = $self->{+CONFIG}->max_slots_per_run; - my $sjmax = $self->{+CONFIG}->max_slots_per_job; - - my $tmin = $task->{min_slots} // 1; - my $tmax = $task->{max_slots} // $tmin; - - my $max = min($tmax, $sjmax, $srmax, $jmax, $rmax); - - # Invalid condition, minimum is more than our maximim - return if $tmin > $max; - $max = $tmin if $max < $tmin; - - return [$tmin, $max]; -} - -sub available { - my $self = shift; - my ($task) = @_; - - my $con = $self->_job_concurrency($task); - return -1 unless $con; - - my $granted = $self->{+STATE}->allocate_slots(con => $con, job_id => $task->{job_id}); - - return unless $granted; - - return $granted -} - -sub assign { - my $self = shift; - my ($task, $state) = @_; - - return if $self->{+OBSERVE}; - - my $info = $self->{+STATE}->assign_slots( - job => { - job_id => $task->{job_id}, - file => $task->{rel_file} // $task->{file} // $task->{job_name}, - }, - ); - - $state->{env_vars}->{T2_HARNESS_MY_JOB_CONCURRENCY} = $info->{count}; - - return $info; -} - -sub record { } # NOOP - -sub release { - my $self = shift; - my ($job_id) = @_; - - return if $self->{+OBSERVE}; - - $self->{+STATE}->release_slots(job_id => $job_id); - - return; -} - -sub status_data { - my $self = shift; - - my @groups; - - my $runners = $self->state->state->{runners}; - - my $global_status = { - todo => 0, - allotted => 0, - assigned => 0, - pending => 0, - }; - - my $time = time; - - for my $runner (sort { $a->{added} <=> $b->{added} } values %$runners) { - my $run_status = { - todo => $runner->{todo}, - allotted => $runner->{allotment}, - assigned => 0, - pending => 0, - }; - - my $job_table = { - header => [qw/Runtime Slots Name/], - format => ['duration', undef, undef], - rows => [], - }; - - for my $job (sort { $a->{started} <=> $b->{started} } values %{$runner->{assigned}}) { - $run_status->{assigned} += $job->{count}; - my $stamp = $job->{started}; - my $slots = $job->{count}; - - push @{$job_table->{rows}} => [$time - $stamp, $slots, $job->{file} // $job->{job_id}]; - } - - $run_status->{pending} = $runner->{allotment} - $run_status->{assigned}; - - $global_status->{$_} += $run_status->{$_} for keys %$global_status; - - my $run_table = { - header => [qw/Todo Allotted Assigned Pending/], - rows => [[$run_status->{todo}, $run_status->{allotted}, $run_status->{assigned}, $run_status->{pending}]], - }; - - push @groups => { - title => "$runner->{user} - $runner->{name} - $runner->{runner_id}", - tables => [ - $run_table, - $job_table, - ], - }; - } - - $global_status->{total} = $self->state->{max_slots}; - $global_status->{free} = $global_status->{total} - ($global_status->{assigned} + $global_status->{pending}); - $global_status->{free} = "$global_status->{free} (Minimum per-run overrides max slot count in some cases)" if $global_status->{free} < 0; - - unshift @groups => { - title => 'System Wide Summary', - tables => [ - { - header => ['Todo', 'Total Shared Slots', 'Allotted Shared Slots', 'Assigned Shared Slots', 'Pending Shared Slots', 'Free Shared Slots'], - rows => [[ @{$global_status}{qw/todo total allotted assigned pending free/} ]], - } - ], - }; - - return \@groups; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Runner::Resource::SharedJobSlots - limit the job count (-j) per machine - -=head1 SYNOPSIS - -B - -In order to use SharedJobSlots you must ether create the C<.sharedjobslots.yml> -file, or provide the C<--shared-jobs-config PATH> argument on the command line. -The C must be a path to a yaml file with configuration specifications for -job sharing. - -=head1 CONFIG FILE - -Config files for shared slots must be yaml file, they must also be parsable by -L, which implements a subset of yaml. - -Here is an example config file: - - --- - DEFAULT: - state_file: /tmp/yath-slot-state - max_slots: 8 - max_slots_per_job: 2 - max_slots_per_run: 6 - - myhostname: - state_file: /tmp/myhostname-slot-state - max_slots: 16 - max_slots_per_job: 4 - max_slots_per_run: 12 - -=head2 TOP LEVEL KEYS (HOSTNAMES) - -All top level keys are hostnames. When the config is read the settings for the -current hostname will be used. If the hostname is not defined then the -C host will be read. If there is no C host defined an -exception will be thrown. - -=head2 CONFIG OPTIONS - -Each option must be specified under a hostname, none of these are valid on -their own. - -=over 4 - -=item state_file: /path/to/shared/state/file - -B - -This specifies the path to the shared state file. All yath processes by all -users who are sharing slots need read+write access to this file. - -=item state_umask: 0007 - -Defaults to C<0007>. Used to set the umask of the state file as well as the -lock file. - -=item max_slots: 8 - -Max slots system-wide for all users to share. - -=item max_slots_per_run: 4 - -Max slots a specific test run can use. - -=item min_slots_per_run: 0 - -Minimum slots per run. - -Set this if you want to make sure that all runs get at least N slots, -B. - -This defaults to 0. - -=item max_slots_per_job: 2 - -Max slots a specific test job (test file) can use. - -=item default_slots_per_run: 4 - -If the user does not specify a number of slots, use this as the default. - -=item default_slots_per_job: 2 - -If the user does not specify a number of job slots, use this as the default. - -=item algorithm: fair - -=item algorithm: first - -=item algorithm: Fully::Qualified::Module::function_name - -Algorithm to use when assigning slots. 'fair' is the default. - -=back - -=head3 ALGORITHMS - -These are algorithms that are used to decide which test runs get which slots. - -=over 4 - -=item fair - -B - -This algorithm tries to balance slots so that all runs share an equal fraction -of available slots. If there are not enough slots to go around then priority -goes to oldest runs, followed by oldest requests. - -=item first - -Priority goes to the oldest run, followed by the next oldest, etc. If the run -age is not sufficient to sort requests this will fall back to 'fair'. - -This is mainly useful for CI systems or batched test boxes. This will give -priority to the first test run started, so additional test runs will not -consume slots the first run wants to use, but if the first run is winding down -and does not need all the slots, the second test run can start using only the -spare slots. - -Use this with ordered test runs where you do not want a purely serial run -order. - -=item Fully::Qualified::Module::function_name - -You can specify custom algorithms by giving fully qualified subroutine names. - -=back - -Example custom algorithm: - - sub custom_sort { - my ($state_object, $state_data, $a, $b) = @_; - - return 1 if a_should_come_first($a, $b); - return -1 if b_should_come_first($a, $b); - return 0 if both_have_same_priority($a, $b); - - # *shrug* - return 0; - } - -Ultimately this is used in a C call, usual rules apply, return should -be 1, 0, or -1. $a and $b are the 2 items being compared. $state_object is an -instance of C. -$state_data is a hashref like you get from C<< $state_object->state() >> which -is useful if you want to know how many slots each runner is using for a 'fair' -style algorth. - -Take a look at the C methods on -C which implement the -3 original sorting methods. - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2022 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Runner/Resource/SharedJobSlots/Config.pm b/lib/Test2/Harness/Runner/Resource/SharedJobSlots/Config.pm deleted file mode 100644 index 353c6761c..000000000 --- a/lib/Test2/Harness/Runner/Resource/SharedJobSlots/Config.pm +++ /dev/null @@ -1,178 +0,0 @@ -package Test2::Harness::Runner::Resource::SharedJobSlots::Config; -use strict; -use warnings; - -our $VERSION = '1.000152'; - -use YAML::Tiny; -use Sys::Hostname qw/hostname/; -use App::Yath::Util qw/find_in_updir/; - -use Test2::Harness::Util::HashBase qw{ - check_prefix('runner')) ? $settings->runner->shared_jobs_config : '.sharedjobslots.yml'; - $config_file = ($base_name =~ m{(/|\\)} || -e $base_name) ? $base_name : find_in_updir($base_name); - } - - return unless $config_file && -e $config_file; - - return $class->new(%opts, config_file => $config_file); -} - -sub init { - my $self = shift; - - my $config_file = $self->{+CONFIG_FILE}; - - my $config = YAML::Tiny->read($config_file) or die "Could not read '$config_file'"; - $config = $self->{+CONFIG_RAW} = $config->[0]; # First doc only - - my $host = $self->{+HOST} //= hostname(); - - # Normalize an empty host config section to a hashref - $config->{$host} ||= {} if exists $config->{$host}; - - unless ($self->{+HOST_CONF} = $config->{$host}) { - if ($self->{+HOST_CONF} = $config->{DEFAULT}) { - $self->{+HOST} = 'DEFAULT'; - } - else { - die "Could not find '$host' or 'DEFAULT' settings in '$config_file'.\n"; - } - - warn <<" EOT" unless $self->{+HOST_CONF}->{no_warning}; -Using the 'DEFAULT' shared-slots host config. -You may want to add the current host to the config file. -To silence this warning, set the 'no_warning' key to true in the DEFAULT host config. - Config File: $config_file -Current Host: $host - EOT - } - - if ($self->{+HOST_CONF}->{use_common} //= 1) { - $self->{+COMMON_CONF} = $config->{'COMMON'} // {}; - } - - $self->{+COMMON_CONF} //= {}; - - #sanity check - $self->max_slots; - - return; -} - -sub state_umask { $_[0]->{+STATE_UMASK} //= $_[0]->_get_config_option(+STATE_UMASK, default => 0007) } -sub state_file { $_[0]->{+STATE_FILE} //= $_[0]->_get_config_option(+STATE_FILE, require => 1) } -sub max_slots { $_[0]->{+MAX_SLOTS} //= $_[0]->_get_config_option(+MAX_SLOTS, required => 1) } -sub min_slots_per_run { $_[0]->{+MIN_SLOTS_PER_RUN} //= $_[0]->_get_config_option(+MIN_SLOTS_PER_RUN, default => 0) } -sub max_slots_per_job { $_[0]->{+MAX_SLOTS_PER_JOB} //= $_[0]->_get_config_option(+MAX_SLOTS_PER_JOB, default => $_[0]->max_slots) } -sub max_slots_per_run { $_[0]->{+MAX_SLOTS_PER_RUN} //= $_[0]->_get_config_option(+MAX_SLOTS_PER_RUN, default => $_[0]->max_slots) } -sub default_slots_per_job { $_[0]->{+DEFAULT_SLOTS_PER_JOB} //= $_[0]->_get_config_option(+DEFAULT_SLOTS_PER_JOB, default => $_[0]->max_slots_per_job) } -sub default_slots_per_run { $_[0]->{+DEFAULT_SLOTS_PER_RUN} //= $_[0]->_get_config_option(+DEFAULT_SLOTS_PER_RUN, default => $_[0]->max_slots_per_run) } - -sub _get_config_option { - my $self = shift; - my ($field, %opts) = @_; - - my $val = $self->{+HOST_CONF}->{$field} // $self->{+COMMON_CONF}->{$field} // $opts{default}; - - die "'$field' not set in '$self->{+CONFIG_FILE}' for host '$self->{+HOST}' or under 'COMMON' config.\n" - if $opts{required} && !defined($val); - - return $val; -} - -sub algorithm { - my $self = shift; - - return $self->{+ALGORITHM} if $self->{+ALGORITHM}; - - my $algorithm = $self->_get_config_option(+ALGORITHM, default => 'fair'); - - if ($algorithm =~ m/^(.*)::([^:]+)$/) { - my ($mod, $sub) = ($1, $2); - require(mod2file($mod)); - } - else { - require Test2::Harness::Runner::Resource::SharedJobSlots::State; - - my $short = $algorithm; - $algorithm = "_redistribute_$algorithm"; - - die "'$short' is not a valid algorithm (in file '$self->{+CONFIG_FILE}' under host '$self->{+HOST}' key 'algorithm'). Must be 'fair', 'first', or a Fully::Qualified::Module::function_name." - unless Test2::Harness::Runner::Resource::SharedJobSlots::State->can($algorithm); - } - - return $self->{+ALGORITHM} = $algorithm; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Runner::Resource::SharedJobSlots::Config - Config for shared job slots - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2022 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Runner/Resource/SharedJobSlots/State.pm b/lib/Test2/Harness/Runner/Resource/SharedJobSlots/State.pm deleted file mode 100644 index 9f809193c..000000000 --- a/lib/Test2/Harness/Runner/Resource/SharedJobSlots/State.pm +++ /dev/null @@ -1,602 +0,0 @@ -package Test2::Harness::Runner::Resource::SharedJobSlots::State; -use strict; -use warnings; - -our $VERSION = '1.000152'; - -use Test2::Harness::Util::File::JSON; -use Scalar::Util qw/weaken/; -use Time::HiRes qw/time/; -use List::Util qw/first min sum0 max/; -use Carp qw/croak confess carp/; -use Fcntl qw/:flock SEEK_END/; -use Errno qw/EINTR EAGAIN ESRCH/; - -use Test2::Harness::Util::HashBase qw{ - {+STATE_FILE}; - croak "'max_slots' is a required attribute" unless $self->{+MAX_SLOTS}; - croak "'max_slots_per_job' is a required attribute" unless $self->{+MAX_SLOTS_PER_JOB}; - croak "'max_slots_per_run' is a required attribute" unless $self->{+MAX_SLOTS_PER_RUN}; - - $self->{+MY_MAX_SLOTS} //= $self->{+MAX_SLOTS}; - $self->{+MY_MAX_SLOTS_PER_JOB} //= $self->{+MAX_SLOTS_PER_JOB}; - - $self->{+MIN_SLOTS_PER_RUN} //= 0; - - $self->{+STATE_UMASK} //= 0007; - - $self->{+NAME} //= $self->{+RUNNER_ID}; - - $self->{+ALGORITHM} //= '_redistribute_fair'; -} - -sub init_state { - my $self = shift; - return { RUNNERS() => {} }; -} - -sub state { shift->transaction('r') } - -sub transaction { - my $self = shift; - my ($mode, $cb, @args) = @_; - - $mode //= 'r'; - - my $write = $mode eq 'w' || $mode eq 'rw'; - my $read = $mode eq 'ro' || $mode eq 'r'; - croak "mode must be 'w', 'rw', 'r', or 'ro', got '$mode'" unless $write || $read; - - confess "Write mode requires a 'runner_id'" if $write && !$self->{+RUNNER_ID}; - confess "Write mode requires a 'runner_pid'" if $write && !$self->{+RUNNER_PID}; - - my ($lock, $state, $local); - if ($state = $self->{+TRANSACTION}) { - $local = $state->{+LOCAL}; - - confess "Attempted a 'write' transaction inside of a read-only transaction" - if $write && !$local->{write}; - } - else { - my $oldmask = umask($self->{+STATE_UMASK}); - - my $ok = eval { - my $lockf = "$self->{+STATE_FILE}.LOCK"; - - open($lock, '>>', $lockf) or die "Could not open lock file '$lockf': $!"; - while (1) { - last if flock($lock, $write ? LOCK_EX : LOCK_SH); - next if $! == EINTR || $! == EAGAIN; - warn "Could not get lock: $!"; - } - - $state = $self->_read_state(); - $local = $state->{+LOCAL} = { - lock => $lock, - mode => $mode, - write => $write, - stack => [{cb => $cb, args => \@args}], - }; - - weaken($state->{+LOCAL}->{lock}); - - 1; - }; - my $err = $@; - umask($oldmask); - die $err unless $ok; - } - - local @{$local}{qw/write mode stack/} = ($write, $mode, [@{$local->{stack}}, {cb => $cb, args => \@args}]) - if $self->{+TRANSACTION}; - - local $self->{+TRANSACTION} = $state; - - if ($write) { - if ($self->{+REGISTERED}) { - $self->_verify_registration($state); - } - else { - $self->_update_registration($state); - } - } - $self->_clear_old_registrations($state); - - my $out; - my $ok = eval { $out = $cb ? $self->$cb($state, @args) : $state; 1 }; - my $err = $@; - - if ($ok && $write) { - $self->_clear_old_registrations($state); - $self->_update_registration($state) unless $self->{+UNREGISTERED}; - $self->_write_state($state); - } - - if ($lock) { - flock($lock, LOCK_UN) or die "Could not release lock: $!"; - } - - die $err unless $ok; - - return $out; -} - -sub _read_state { - my $self = shift; - - return $self->init_state unless -e $self->{+STATE_FILE}; - - my $file = Test2::Harness::Util::File::JSON->new(name => $self->{+STATE_FILE}); - - my ($ok, $err); - for (1 .. 5) { - my $state; - $ok = eval { $state = $file->maybe_read(); 1}; - $err = $@; - - return $state ||= $self->init_state if $ok; - - sleep 0.2; - } - - warn "Corrupted state? Resetting state to initial. Error that caused this was:\n======\n$err\n======\n"; - - return $self->init_state; -} - -sub _write_state { - my $self = shift; - my ($state) = @_; - - my $state_copy = {%$state}; - - my $local = delete $state_copy->{+LOCAL}; - - confess "Attempted write with no lock" unless $local->{lock}; - confess "Attempted write with a read-only lock" unless $local->{write}; - - my $oldmask = umask($self->{+STATE_UMASK}); - my $ok = eval { - my $file = Test2::Harness::Util::File::JSON->new(name => $self->{+STATE_FILE}); - $file->rewrite($state_copy); - 1; - }; - my $err = $@; - - umask($oldmask); - - die $err unless $ok; -} - -sub update_registration { $_[0]->transaction(rw => '_update_registration') } -sub remove_registration { $_[0]->transaction(rw => '_update_registration', remove => 1) } - -sub _update_registration { - my $self = shift; - my ($state, %params) = @_; - - my $runner_id = $self->{+RUNNER_ID}; - my $runner_pid = $self->{+RUNNER_PID}; - my $entry = $state->{runners}->{$runner_id} //= $state->{runners}->{$runner_id} = { - runner_id => $runner_id, - runner_pid => $runner_pid, - name => $self->{+NAME}, - dir => $self->{+DIR}, - user => $ENV{USER}, - added => time, - - todo => 0, - allocated => 0, - allotment => 0, - assigned => {}, - - max_slots => $self->{+MY_MAX_SLOTS}, - max_slots_per_job => $self->{+MY_MAX_SLOTS_PER_JOB}, - }; - - # Update our last checking time - $entry->{seen} = time; - - $self->{+REGISTERED} = 1; - - return $state unless $params{remove}; - - $self->{+UNREGISTERED} = 1; - $entry->{remove} = 1; - - return $state; -} - -sub _verify_registration { - my $self = shift; - my ($state) = @_; - - return unless $self->{+REGISTERED}; - - my $runner_id = $self->{+RUNNER_ID}; - my $entry = $state->{+RUNNERS}->{$runner_id}; - - # Do not allow for a new expiration. If the state has already expired us we will see it. - $entry->{seen} = time if $entry; - - return unless $self->{+UNREGISTERED} //= $self->_entry_expired($entry); - - confess "Shared slot registration expired"; -} - -sub _entry_expired { - my $self = shift; - my ($entry) = @_; - - return 1 unless $entry; - return 1 if $entry->{remove}; - - if (my $pid = $entry->{runner_pid}) { - my $ret = kill(0, $pid); - my $err = $!; - return 1 if $ret == 0 && $! == ESRCH; - } - - my $seen = $entry->{seen} or return 1; - my $delta = time - $seen; - - return 1 if $delta > TIMEOUT(); - - return 0; -} - -sub _clear_old_registrations { - my $self = shift; - my ($state) = @_; - - my $runners = $state->{+RUNNERS} //= {}; - - my (%removed); - for my $entry (values %$runners) { - $entry->{remove} = 1 if $self->_entry_expired($entry); - next unless $entry->{remove}; - - my $runner_id = $entry->{runner_id}; - - $self->{+UNREGISTERED} = 1 if $runner_id eq $self->{+RUNNER_ID}; - - delete $runners->{$runner_id}; - - $removed{$runner_id}++; - } - - return \%removed; -} - -sub allocate_slots { - my $self = shift; - my (%params) = @_; - - my $con = $params{con} or croak "'con' is required"; - my $job_id = $params{job_id} or croak "'job_id' is required"; - - return $self->transaction(rw => '_allocate_slots', con => $con, job_id => $job_id); -} - -sub assign_slots { - my $self = shift; - my (%params) = @_; - - my $job = $params{job} or croak "'job' is required"; - - return $self->transaction(rw => '_assign_slots', job => $job); -} - -sub release_slots { - my $self = shift; - my (%params) = @_; - - my $job_id = $params{job_id} or croak "'job_id' is required"; - - return $self->transaction(rw => '_release_slots', job_id => $job_id); -} - -sub _allocate_slots { - my $self = shift; - my ($state, %params) = @_; - - my $entry = $state->{runners}->{$self->{+RUNNER_ID}}; - delete $entry->{_calc_cache}; - - my $job_id = $params{job_id}; - my $con = $params{con}; - my ($min, $max) = @$con; - $self->_runner_todo($entry, $job_id => $max); - - my $allocated = $entry->{allocated}; - - # We have what we need already allocated - return $entry->{allocated} = $max - if $max <= $allocated; - - return $entry->{allocated} - if $entry->{allocated} >= $min; - - # Our allocation, if any, is not big enough, free it so we do not have a - # deadlock with all runner holding an insufficient allocation. - $allocated = $entry->{allocated} = 0; - - my $calcs = $self->_runner_calcs($entry); - - for (0 .. 1) { - $self->_redistribute($state) if $_; # Only run on second loop - - # Cannot do anything if we have no allotment or no available slots. - # This will go to the next loop for a redistribution, or end the loop. - my $allotment = $entry->{allotment} or next; - my $available = $allotment - $calcs->{assigned} or next; - - # If we get here we have an allotment (not 0) but it does not mean the - # minimum, so we have to skip the test. - return -1 if $allotment < $min; - - next unless $available >= $min; - - return $entry->{allocated} = min($available, $max); - } - - return 0; -} - -sub _assign_slots { - my $self = shift; - my ($state, %params) = @_; - - my $entry = $state->{runners}->{$self->{+RUNNER_ID}}; - delete $entry->{_calc_cache}; - - my $job = $params{job}; - my $job_id = $job->{job_id}; - my $allocated = $entry->{allocated}; - - $self->_runner_todo($entry, $job_id => -1); - - $job->{count} = $allocated; - $job->{started} = time; - - $entry->{allocated} = 0; - - $entry->{assigned}->{$job->{job_id}} = $job; - - return $job; -} - -sub _release_slots { - my $self = shift; - my ($state, %params) = @_; - - my $entry = $state->{runners}->{$self->{+RUNNER_ID}}; - - my $job_id = $params{job_id}; - - delete $entry->{assigned}->{$job_id}; - delete $entry->{_calc_cache}; - - $self->_runner_todo($entry, $job_id => -1); - - # Reduce our allotment if it makes sense to do so. - my $calcs = $self->_runner_calcs($entry); - $entry->{allotment} = $calcs->{total} if $entry->{allotment} > $calcs->{total}; -} - -sub _runner_todo { - my $sef = shift; - my ($entry, $job_id, $count) = @_; - - my $jobs = $entry->{jobs} //= {}; - - if ($count) { - if ($count < 0) { - $count = delete $jobs->{$job_id}; - } - else { - $jobs->{$job_id} = $count; - } - } - elsif ($job_id) { - $count = $jobs->{$job_id}; - } - - $entry->{todo} = sum0(values %$jobs); - - return $count; -} - -sub _runner_calcs { - my $self = shift; - my ($runner) = @_; - - return $runner->{_calc_cache} if $runner->{_calc_cache}; - - my $max = min(grep {$_} $self->{+MAX_SLOTS_PER_RUN}, $runner->{max_slots}); - my $assigned = sum0(map { $_->{count} } values %{$runner->{assigned} //= {}}); - my $active = $runner->{allocated} + $assigned; - my $total = $runner->{todo} + $active; - my $wants = ($total >= $max) ? max($max, $active) : max($total, $active); - - return $runner->{_calc_cache} = { - max => $max, - assigned => $assigned, - active => $active, - total => $total, - wants => $wants, - }; -} - -sub _redistribute { - my $self = shift; - my ($state) = @_; - - my $max_run = $self->{+MAX_SLOTS_PER_RUN}; - - my $wanted = 0; - for my $runner (values %{$state->{+RUNNERS}}) { - my $calcs = $self->_runner_calcs($runner); - $runner->{allotment} = $calcs->{wants}; - $wanted += $calcs->{wants}; - } - - # Everyone gets what they want! - my $max = $self->{+MAX_SLOTS}; - return if $wanted <= $max; - - my $meth = $self->{+ALGORITHM}; - - return $self->$meth($state); -} - -sub _redistribute_first { - my $self = shift; - my ($state) = @_; - - my $min = $self->{+MIN_SLOTS_PER_RUN}; - my $max = $self->{+MAX_SLOTS}; - - my $c = 0; - for my $runner (sort { $a->{added} <=> $b->{added} } values %{$state->{+RUNNERS}}) { - my $calcs = $self->_runner_calcs($runner); - my $wants = $calcs->{wants}; - - if ($max >= $wants) { - $runner->{allotment} = $wants; - } - else { - $runner->{allotment} = max($max, $min, 0); - } - - $max -= $runner->{allotment}; - - $c++; - } - - return; -} - -sub _redistribute_fair { - my $self = shift; - my ($state) = @_; - - my $runs = scalar keys %{$state->{+RUNNERS}}; - - # Avoid a divide by 0 below. - return unless $runs; - - my $total = $self->{+MAX_SLOTS}; - my $min = $self->{+MIN_SLOTS_PER_RUN}; - - my $used = 0; - for my $runner (values %{$state->{+RUNNERS}}) { - my $calcs = $self->_runner_calcs($runner); - - # We never want less than the 'active' number - my $set = $calcs->{active}; - - # If min is greater than the active number and there are todo tests, we - # use the min instead. - $set = $min if $set < $min && $runner->{todo}; - - $runner->{allotment} = $set; - $used += $set; - } - - my $free = $total - $used; - return unless $free >= 1; - - # Is there a more efficient way to do this? Yikes! - my @runners = values %{$state->{+RUNNERS}}; - while ($free > 0) { - @runners = sort { $a->{allotment} <=> $b->{allotment} || $a->{added} <=> $b->{added} } - grep { my $c = $self->_runner_calcs($_); $c->{wants} > $_->{allotment} } - @runners; - - $free--; - $runners[0]->{allotment}++; - } - - return; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Runner::Resource::SharedJobSlots::State - shared state for job slots - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2022 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Runner/Run.pm b/lib/Test2/Harness/Runner/Run.pm deleted file mode 100644 index 8826c3e52..000000000 --- a/lib/Test2/Harness/Runner/Run.pm +++ /dev/null @@ -1,104 +0,0 @@ -package Test2::Harness::Runner::Run; -use strict; -use warnings; - -our $VERSION = '1.000152'; - -use Carp qw/croak/; -use File::Spec(); - -use Test2::Harness::Util::File::JSONL; - -use parent 'Test2::Harness::Run'; -use Test2::Harness::Util::HashBase qw{ - SUPER::init(); - - croak "'workdir' is a required attribute" unless $self->{+WORKDIR}; -} - -sub run_dir { $_[0]->{+RUN_DIR} //= $_[0]->SUPER::run_dir($_[0]->{+WORKDIR}) } -sub jobs_file { $_[0]->{+JOBS_FILE} //= File::Spec->catfile($_[0]->run_dir, 'jobs.jsonl') } -sub jobs { $_[0]->{+JOBS} //= Test2::Harness::Util::File::JSONL->new(name => $_[0]->jobs_file, use_write_lock => 1) } - -1; - -__END__ - - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Runner::Run - Runner specific subclass of a test run. - -=head1 DESCRIPTION - -Runner subclass of L for use inside the runner. - -=head1 METHODS - -In addition to the methods provided by L, these are provided. - -=over 4 - -=item $dir = $run->workdir - -Runner directory. - -=item $dir = $run->run_dir - -Directory specific to this run. - -=item $path = $run->jobs_file - -Path to the C file. - -=item $fh = $run->jobs - -Filehandle to C. - -=back - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Runner/Spawn.pm b/lib/Test2/Harness/Runner/Spawn.pm deleted file mode 100644 index 5bb3b83f3..000000000 --- a/lib/Test2/Harness/Runner/Spawn.pm +++ /dev/null @@ -1,89 +0,0 @@ -package Test2::Harness::Runner::Spawn; -use strict; -use warnings; - -our $VERSION = '1.000152'; - -use parent 'Test2::Harness::Runner::Job'; -use Test2::Harness::Util::HashBase; - -sub init { - my $self = shift; - - $self->{+RUN} //= Test2::Harness::Runner::Spawn::Run->new(); -} - -sub out_file { sprintf('/proc/%i/fd/1', $_[0]->{+TASK}->{owner}) } -sub err_file { sprintf('/proc/%i/fd/2', $_[0]->{+TASK}->{owner}) } -sub in_file { undef } - -sub args { @{$_[0]->{+TASK}->{args} //= []} } - -sub job_dir { "" } -sub run_dir { "" } - -sub use_stream { 0 } -sub event_uuids { 0 } -sub mem_usage { 0 } -sub io_events { 0 } - -# These return lists -sub load_import { } -sub load { } - -package Test2::Harness::Runner::Spawn::Run; - -sub new { bless {}, shift }; - -sub env_vars { {} } - -sub AUTOLOAD { } - -1; - -__END__ - - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Runner::Spawn - Minimal job class used for spawning processes - -=head1 DESCRIPTION - -Do not use this directly... - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Runner/State.pm b/lib/Test2/Harness/Runner/State.pm deleted file mode 100644 index 3f69ed697..000000000 --- a/lib/Test2/Harness/Runner/State.pm +++ /dev/null @@ -1,865 +0,0 @@ -package Test2::Harness::Runner::State; -use strict; -use warnings; - -our $VERSION = '1.000152'; - -use Carp qw/croak/; - -use File::Spec; -use Time::HiRes qw/time/; -use List::Util qw/first/; - -use Test2::Harness::Util qw/mod2file/; - -use Test2::Harness::Settings; -use Test2::Harness::Runner::Constants; - -use Test2::Harness::Runner::Run; -use Test2::Harness::Util::Queue; - -use Test2::Harness::Util::UUID qw/gen_uuid/; - -use Test2::Harness::Util::HashBase( - # These are construction arguments - qw{ - {+WORKDIR}; - - $self->{+JOB_COUNT} //= $self->settings->runner->job_count // 1; - - if (!$self->{+RESOURCES} || !@{$self->{+RESOURCES}}) { - my $settings = $self->settings; - my $resources = $self->{+RESOURCES} //= []; - for my $res (@{$self->settings->runner->resources}) { - require(mod2file($res)); - push @$resources => $res->new(settings => $self->settings, observe => $self->{+OBSERVE}); - } - } - - unless (grep { $_->job_limiter } @{$self->{+RESOURCES}}) { - require Test2::Harness::Runner::Resource::JobCount; - push @{$self->{+RESOURCES}} => Test2::Harness::Runner::Resource::JobCount->new(job_count => $self->{+JOB_COUNT}, settings => $self->settings); - } - - @{$self->{+RESOURCES}} = sort { $a->sort_weight <=> $b->sort_weight } @{$self->{+RESOURCES}}; - - $self->{+DISPATCH_FILE} = Test2::Harness::Util::Queue->new(file => File::Spec->catfile($self->{+WORKDIR}, 'dispatch.jsonl')); - - $self->{+RELOAD_STATE} //= {}; - - $self->poll; -} - -sub settings { - my $self = shift; - return $self->{+SETTINGS} //= Test2::Harness::Settings->new(File::Spec->catfile($self->{+WORKDIR}, 'settings.json')); -} - -sub run { - my $self = shift; - return $self->{+RUN} if $self->{+RUN}; - $self->poll(); - return $self->{+RUN}; -} - -sub done { - my $self = shift; - - $self->poll(); - - return 0 if $self->{+RUNNING}; - return 0 if keys %{$self->{+PENDING_TASKS} //= {}}; - - return 0 if $self->{+RUN}; - return 0 if @{$self->{+PENDING_RUNS} //= []}; - - return 0 unless $self->{+QUEUE_ENDED}; - - return 1; -} - -sub next_task { - my $self = shift; - my ($stage) = @_; - - $self->poll(); - $self->clear_finished_run(); - - while(1) { - if (@{$self->{+PENDING_SPAWNS} //= []}) { - my $spawn = shift @{$self->{+PENDING_SPAWNS}}; - next unless $spawn->{stage} eq $stage; - $self->start_spawn($spawn); - return $spawn; - } - - my $task = shift @{$self->{+TASK_LIST}} or return undef; - - # If we are replaying a state then the task may have already completed, - # so skip it if it is not in the running lookup. - next unless $self->{+RUNNING_TASKS}->{$task->{job_id}}; - next unless $task->{stage} eq $stage; - - return $task; - } -} - -sub advance { - my $self = shift; - $self->poll(); - - $_->tick() for @{$self->{+RESOURCES} //= []}; - - $self->advance_run(); - return 0 unless $self->{+RUN}; - return 1 if $self->advance_tasks(); - return $self->clear_finished_run(); -} - -my %ACTIONS = ( - queue_run => '_queue_run', - queue_task => '_queue_task', - queue_spawn => '_queue_spawn', - start_spawn => '_start_spawn', - start_run => '_start_run', - start_task => '_start_task', - stop_run => '_stop_run', - stop_task => '_stop_task', - retry_task => '_retry_task', - stage_ready => '_stage_ready', - stage_down => '_stage_down', - end_queue => '_end_queue', - halt_run => '_halt_run', - truncate => '_truncate', - reload => '_reload', -); - -sub poll { - my $self = shift; - - return if $self->{+NO_POLL}; - - my $queue = $self->dispatch_file; - - for my $item ($queue->poll) { - my $data = $item->[-1]; - my $item = $data->{item}; - my $action = $data->{action}; - my $pid = $data->{pid}; - - my $sub = $ACTIONS{$action} or die "Invalid action '$action'"; - - $self->$sub($item, $pid); - } -} - -sub _enqueue { - my $self = shift; - my ($action, $item) = @_; - $self->{+DISPATCH_FILE}->enqueue({action => $action, item => $item, stamp => time, pid => $$}); - $self->poll; -} - -sub truncate { - my $self = shift; - $self->halt_run($_) for keys %{$self->{+PENDING_TASKS} // {}}; - $self->_enqueue(truncate => $$); - $self->poll; -} - -sub _truncate { } - -sub end_queue { $_[0]->_enqueue('end_queue' => 1) } -sub _end_queue { $_[0]->{+QUEUE_ENDED} = 1 } - -sub halt_run { - my $self = shift; - my ($run_id) = @_; - $self->_enqueue(halt_run => $run_id); - - my $dir = File::Spec->catdir($self->{+WORKDIR}, $run_id); - my $file = File::Spec->catfile($dir, 'jobs.jsonl'); - - if (-f $file) { - my $queue = Test2::Harness::Util::Queue->new(file => File::Spec->catfile($dir, 'jobs.jsonl')); - $queue->end; - } -} - -sub _halt_run { - my $self = shift; - my ($run_id) = @_; - - delete $self->{+PENDING_TASKS}->{$run_id}; - - $self->{+HALTED_RUNS}->{$run_id}++; -} - -sub queue_run { - my $self = shift; - my ($run) = @_; - $self->_enqueue(queue_run => $run); -} - -sub _queue_run { - my $self = shift; - my ($run) = @_; - - push @{$self->{+PENDING_RUNS}} => Test2::Harness::Runner::Run->new( - %$run, - workdir => $self->{+WORKDIR}, - ); - - return; -} - -sub start_run { - my $self = shift; - my ($run_id) = @_; - $self->_enqueue(start_run => $run_id); -} - -sub _start_run { - my $self = shift; - my ($run_id) = @_; - - my $run = shift @{$self->{+PENDING_RUNS}}; - die "$0 - Run stack mismatch, run start requested, but no pending runs to start" unless $run; - die "$0 - Run stack mismatch, run-id does not match next pending run" unless $run->run_id eq $run_id; - - $self->{+RUN} = $run; - - return; -} - -sub stop_run { - my $self = shift; - my ($run_id) = @_; - $self->_enqueue(stop_run => $run_id); -} - -sub _stop_run { - my $self = shift; - my ($run_id) = @_; - - $self->{+STOPPED_RUNS}->{$run_id} = 1; - - return; -} - -sub queue_spawn { - my $self = shift; - my ($spawn) = @_; - $spawn->{spawn} //= 1; - $spawn->{id} //= gen_uuid(); - $self->_enqueue(queue_spawn => $spawn); -} - -sub _queue_spawn { - my $self = shift; - my ($spawn) = @_; - - $spawn->{id} //= gen_uuid(); - $spawn->{spawn} //= 1; - $spawn->{use_preload} //= 1; - - $spawn->{stage} //= 'default'; - $spawn->{stage} = $self->task_stage($spawn); - - push @{$self->{+PENDING_SPAWNS}} => $spawn; - - return; -} - -sub start_spawn { - my $self = shift; - my ($spec) = @_; - $self->_enqueue(start_spawn => $spec); -} - -sub _start_spawn { - my $self = shift; - my ($spec) = @_; - - my $uuid = $spec->{id} or die "Could not find UUID for spawn"; - - @{$self->{+PENDING_SPAWNS}} = grep { $_->{id} ne $uuid } @{$self->{+PENDING_SPAWNS}}; - - return; -} - -sub queue_task { - my $self = shift; - my ($task) = @_; - $self->_enqueue(queue_task => $task); -} - -sub _queue_task { - my $self = shift; - my ($task) = @_; - - my $job_id = $task->{job_id} or die "Task missing job_id"; - my $run_id = $task->{run_id} or die "Task missing run_id"; - - die "Task already in queue" if $self->{+TASK_LOOKUP}->{$job_id}; - - return if $self->{+HALTED_RUNS}->{$run_id}; - - $self->{+TASK_LOOKUP}->{$job_id} = $task; - - my $pending = $self->task_pending_lookup($task); - push @{$pending} => $task; - - return; -} - -sub start_task { - my $self = shift; - my ($spec) = @_; - $self->_enqueue(start_task => $spec); -} - -sub _start_task { - my $self = shift; - my ($spec) = @_; - - my $job_id = $spec->{job_id} or die "No job_id provided"; - my $run_stage = $spec->{stage} or die "No stage provided"; - my $res = $spec->{res} or die "No res provided"; - my $res_skip = $spec->{resource_skip}; - - my $task = $self->{+TASK_LOOKUP}->{$job_id} or die "Could not find task to start"; - - my ($run_id, $smoke, $stage, $cat, $dur) = $self->task_fields($task); - - my $set = $self->{+PENDING_TASKS}->{$run_id}->{$smoke}->{$stage}->{$cat}->{$dur}; - my $count = @$set; - @$set = grep { $_->{job_id} ne $job_id } @$set; - die "Task $job_id was not pending ($count -> " . scalar(@$set) . ")" unless $count > @$set; - - $self->prune_hash($self->{+PENDING_TASKS}, $run_id, $smoke, $stage, $cat, $dur); - - # Set the stage, new task hashref - $task = {%$task, stage => $run_stage} unless $task->{stage} && $task->{stage} eq $run_stage; - - $task->{env_vars}->{$_} = $res->{env_vars}->{$_} for keys %{$res->{env_vars}}; - push @{$task->{test_args}} => @{$res->{args}}; - - for my $resource (@{$self->{+RESOURCES}}) { - my $class = ref($resource); - my $val = $res->{record}->{$class} // next; - $resource->record($task->{job_id}, $val); - } - - die "Already running task $job_id" if $self->{+RUNNING_TASKS}->{$job_id}; - $self->{+RUNNING_TASKS}->{$job_id} = $task; - - $task->{resource_skip} = $res_skip if $res_skip; - - push @{$self->{+TASK_LIST}} => $task; - - $self->{+RUNNING}++; - $self->{+RUNNING_CATEGORIES}->{$cat}++; - $self->{+RUNNING_DURATIONS}->{$dur}++; - - my $cfls = $task->{conflicts} //= []; - for my $cfl (@$cfls) { - die "Unexpected parallel conflict '$cfl' ($self->{+RUNNING_CONFLICTS}->{$cfl}) running at this time!" - if $self->{+RUNNING_CONFLICTS}->{$cfl}++; - } - - return; -} - -sub stop_task { - my $self = shift; - my ($job_id) = @_; - $self->_enqueue(stop_task => $job_id); -} - -sub _stop_task { - my $self = shift; - my ($job_id) = @_; - - my $task = delete $self->{+TASK_LOOKUP}->{$job_id} or die "Could not find task to stop ($job_id)"; - - delete $self->{+RUNNING_TASKS}->{$job_id} or die "Task is not running, cannot stop it ($job_id)"; - - $_->release($job_id) for @{$self->{+RESOURCES}}; - - my ($run_id, $smoke, $stage, $cat, $dur) = $self->task_fields($task); - $self->{+RUNNING}--; - $self->{+RUNNING_CATEGORIES}->{$cat}--; - $self->{+RUNNING_DURATIONS}->{$dur}--; - - my $cfls = $task->{conflicts} //= []; - $self->{+RUNNING_CONFLICTS}->{$_}-- for @$cfls; - - return; -} - -sub retry_task { - my $self = shift; - my ($job_id) = @_; - - $self->_enqueue(retry_task => $job_id); -} - -sub _retry_task { - my $self = shift; - my ($job_id) = @_; - - my $task = $self->{+TASK_LOOKUP}->{$job_id} or die "Could not find task to retry"; - - $self->_stop_task($job_id); - - return if $self->{+HALTED_RUNS}->{$task->{run_id}}; - - $task = {is_try => 0, %$task}; - $task->{is_try}++; - $task->{category} = 'isolation' if $self->{+RUN}->retry_isolated; - - $self->_queue_task($task); - - return; -} - -sub stage_ready { - my $self = shift; - my ($stage) = @_; - $self->_enqueue(stage_ready => $stage); -} - -sub _stage_ready { - my $self = shift; - my ($stage, $pid) = @_; - - $self->{+STAGE_READINESS}->{$stage} = $pid // 1; - - return; -} - -sub stage_down { - my $self = shift; - my ($stage) = @_; - $self->_enqueue(stage_down => $stage); -} - -sub _stage_down { - my $self = shift; - my ($stage) = @_; - - $self->{+STAGE_READINESS}->{$stage} = 0; - - return; -} - -sub reload { - my $self = shift; - my ($stage, $data) = @_; - $stage //= 'default'; - $self->_enqueue(reload => {%$data, stage => $stage}); - return; -} - -sub _reload { - my $self = shift; - my ($data) = @_; - - my $stage = $data->{stage}; - my $file = $data->{file}; - my $success = $data->{reloaded}; - my $error = $data->{error}; - my $warnings = $data->{warnings}; - - my $reload_state = $self->{+RELOAD_STATE} //= {}; - my $stage_state = $reload_state->{$stage} //= {}; - - # It either succeeded, or the stage will be reloaded, no need to track brokenness - if (defined $success) { - delete $stage_state->{$file}; - } - else { - my $fields = {}; - $fields->{error} = $error if defined($error) && length($error); - $fields->{warnings} = $warnings if $warnings && @{$warnings}; - - if (keys %$fields) { - $stage_state->{$file} = $fields; - } - else { - delete $stage_state->{$file}; - } - } - - return; -} - -sub task_stage { - my $self = shift; - my ($task) = @_; - - my $wants = $task->{stage}; - $wants //= 'NOPRELOAD' unless $task->{use_preload}; - - return $wants if $self->{+NO_POLL}; - - return $wants // 'DEFAULT' unless $self->preloader; - return $self->preloader->task_stage($task->{file}, $wants); -} - -sub task_pending_lookup { - my $self = shift; - my ($task) = @_; - - my ($run_id, $smoke, $stage, $cat, $dur) = $self->task_fields($task); - - return $self->{+PENDING_TASKS}->{$run_id}->{$smoke}->{$stage}->{$cat}->{$dur} //= []; -} - -sub task_fields { - my $self = shift; - my ($task) = @_; - - my $run_id = $task->{run_id} or die "No run id provided by task"; - my $smoke = $task->{smoke} ? 'smoke' : 'main'; - my $stage = $self->task_stage($task); - - my $cat = $task->{category}; - my $dur = $task->{duration}; - - die "Invalid category: $cat" unless CATEGORIES->{$cat}; - die "Invalid duration: $dur" unless DURATIONS->{$dur}; - - $cat = 'conflicts' if $cat eq 'general' && $task->{conflicts} && @{$task->{conflicts}}; - - return ($run_id, $smoke, $stage, $cat, $dur); -} - -sub prune_hash { - my $self = shift; - my ($hash, @path) = @_; - - die "No path!" unless @path; - - my $key = shift @path; - - if (@path) { - my $empty = $self->prune_hash($hash->{$key}, @path); - return 0 unless $empty; - } - - return 1 unless exists $hash->{$key}; - - my $ref = ref($hash->{$key}); - if ($ref eq 'HASH') { - return 0 if keys %{$hash->{$key}}; - } - elsif ($ref eq 'ARRAY') { - return 0 if @{$hash->{$key}}; - } - - delete $hash->{$key}; - return 1; -} - -sub advance_run { - my $self = shift; - - return 0 if $self->{+RUN}; - - return 0 unless @{$self->{+PENDING_RUNS} //= []}; - $self->start_run($self->{+PENDING_RUNS}->[0]->run_id); - - return 1; -} - -sub clear_finished_run { - my $self = shift; - - my $run = $self->{+RUN} or return 0; - - return 0 unless $self->{+STOPPED_RUNS}->{$run->run_id}; - return 0 if $self->{+PENDING_TASKS}->{$run->run_id}; - return 0 if $self->{+RUNNING}; - - delete $self->{+RUN}; - - return 1; -} - -sub advance_tasks { - my $self = shift; - - for my $resource (@{$self->{+RESOURCES}}) { - $resource->refresh(); - - next unless $resource->job_limiter; - return 0 if $resource->job_limiter_at_max(); - } - - my ($run_stage, $task, $res, %params) = $self->_next(); - - my $out = 0; - if ($task) { - $out = 1; - $self->start_task({job_id => $task->{job_id}, stage => $run_stage, res => $res, %params}); - } - - $_->discharge() for @{$self->{+RESOURCES}}; - - return $out; -} - -sub _cat_order { - my $self = shift; - - my @cat_order = ('conflicts', 'general'); - - # Only search immiscible if we have no immiscible running - # put them first if no others are running so we can churn through them - # early instead of waiting for them to run 1 at a time at the end. - unshift @cat_order => 'immiscible' unless $self->{+RUNNING_CATEGORIES}->{immiscible}; - - # Only search isolation if nothing is running. - push @cat_order => 'isolation' unless $self->{+RUNNING}; - - return \@cat_order; -} - -sub _dur_order { - my $self = shift; - - my $max = 0; - for my $resource (@{$self->resources}) { - next unless $resource->job_limiter; - my $val = $resource->job_limiter_max; - $max = $val if !$max || $val < $max; - } - $max //= 1; - - my $maxm1 = $max - 1; - - my $durs = $self->{+RUNNING_DURATIONS}; - - # 'short' is always ok. - my @dur_order = ('short'); - - # long and medium should be on the front of the search unless we are - # already running (max - 1) tests of the duration We want long first if - # we are not saturation on them, followed by medium, whcih is why they - # are listed in this order. - for my $c (qw/medium long/) { - if ($durs->{$c} && $durs->{$c} >= $maxm1) { - push @dur_order => $c; # Back of the list - } - else { - unshift @dur_order => $c; # Front of the list - } - } - - return \@dur_order; -} - -# This returns a list of [STAGE => RUN_STAGE] pairs. 'STAGE' is the stage in -# which we search for tasks, 'RUN_STAGE' is the stage that actually does the -# work. This is what allows us to find tasks for 'eager' stages that are bored. -sub _stage_order { - my $self = shift; - - my $stage_check = $self->{+STAGE_READINESS} //= {}; - - my @stage_list = sort grep { $stage_check->{$_} } keys %$stage_check; - - # Populate list with all ready stages - my %seen; - my @stages = map {[$_ => $_]} grep { !$seen{$_}++ } @stage_list; - - # Add in any eager stages, but make sure they are last. - for my $rstage (@stage_list) { - next unless exists $self->{+EAGER_STAGES}->{$rstage}; - push @stages => map {[$_ => $rstage]} grep { !$seen{$_}++ } @{$self->{+EAGER_STAGES}->{$rstage}}; - } - - return \@stages; -} - -my %SORTED; -sub _next { - my $self = shift; - - my $run = $self->{+RUN} or return; - my $run_id = $run->run_id; - - my $pending = $self->{+PENDING_TASKS}->{$run_id} or return; - - my $conflicts = $self->{+RUNNING_CONFLICTS}; - my $cat_order = $self->_cat_order; - my $dur_order = $self->_dur_order; - my $stages = $self->_stage_order(); - my $resources = $self->{+RESOURCES}; - - # Ugly.... - my $search = $pending; - - for my $smoke (qw/smoke main/) { - my $search = $search->{$smoke} or next; - - for my $stage_set (@$stages) { - my ($lstage, $run_by_stage) = @$stage_set; - my $search = $search->{$lstage} or next; - - for my $lcat (@$cat_order) { - my $search = $search->{$lcat} or next; - - for my $ldur (@$dur_order) { - my $search = $search->{$ldur} or next; - - # Make sure anything with conflicts runs early. - unless ($SORTED{$search}++) { - @$search = sort { scalar(@{$b->{conflicts}}) <=> scalar(@{$a->{conflicts}}) } @$search; - } - - for my $task (@$search) { - # If the job has a listed conflict and an existing job is running with that conflict, then pick another job. - next if first { $conflicts->{$_} } @{$task->{conflicts}}; - - my $ok = 1; - my @resource_skip; - for my $resource (@$resources) { - my $out = $resource->available($task) || 0; # normalize false to 0 - - push @resource_skip => ref($resource) || $resource if $out < 0; - - $ok &&= $out; - - # If we have a temporarily unavailable resource we - # skip, but if any resource is never avilable - # (skip) we want to finish the loop to add them all - # for the skip message. - last if !$ok && !@resource_skip; - } - - # Some resource is temporarily not available - next unless $ok; - - my $outres = {args => [], env_vars => {}, record => {}}; - - my @out = ($run_by_stage => $task, $outres); - - my @record = @$resources; - - if (@resource_skip) { - push @out => (resource_skip => \@resource_skip); - - # Only the job limiter resources need to be recorded. - @record = grep { $_->job_limiter } @record; - } - - for my $resource (@record) { - my $res = {args => [], env_vars => {}}; - $resource->assign($task, $res); - push @{$outres->{args}} => @{$res->{args}}; - $outres->{env_vars}->{$_} = $res->{env_vars}->{$_} for keys %{$res->{env_vars}}; - $outres->{record}->{ref($resource)} = $res->{record}; - } - - return @out; - } - } - } - } - } - - return; -} - -1; - -__END__ - - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Runner::State - State tracking for the runner. - -=head1 DESCRIPTION - -This module tracks the state for all running tests. This entire module is -considered an "Implementation Detail". Please do not rely on it always staying -the same, or even existing in the future. Do not use this directly. - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut diff --git a/lib/Test2/Harness/Scheduler.pm b/lib/Test2/Harness/Scheduler.pm new file mode 100644 index 000000000..21120ea05 --- /dev/null +++ b/lib/Test2/Harness/Scheduler.pm @@ -0,0 +1,46 @@ +package Test2::Harness::Scheduler; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp qw/confess/; + +use Test2::Harness::Util::HashBase qw{ + runner +}; + +sub init { } + +sub queue_run { + my $self = shift; + my ($run) = @_; + + confess "queue_run() is not implemented"; +} + +sub advance { + my $self = shift; + my ($runner) = @_; + + confess "advance() is not implemented"; +} + +sub job_update { + my $self = shift; + my ($update) = @_; + + confess "job_update() is not implemented"; +} + +sub start { + my $self = shift; + $self->runner->start(); +} + +sub abort { confess "'abort() is not implemented" } +sub kill { confess "'kill() is not implemented" } + +sub terminate { } + +1; diff --git a/lib/Test2/Harness/Scheduler/Default.pm b/lib/Test2/Harness/Scheduler/Default.pm new file mode 100644 index 000000000..333196ede --- /dev/null +++ b/lib/Test2/Harness/Scheduler/Default.pm @@ -0,0 +1,1844 @@ +package Test2::Harness::Scheduler::Default; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use Carp qw/croak/; +use POSIX qw/:sys_wait_h/; +use List::Util qw/first/; +use Time::HiRes qw/time/; + +use Test2::Harness::Scheduler::Default::Run; +use Test2::Harness::IPC::Protocol; +use Test2::Harness::Event; + +use Test2::Harness::Util qw/hash_purge/; +use Test2::Harness::IPC::Util qw/ipc_warn/; +use Test2::Harness::Util::UUID qw/gen_uuid/; +use Test2::Harness::Util::JSON qw/encode_pretty_json/; + +use parent 'Test2::Harness::Scheduler'; +use Test2::Harness::Util::HashBase qw{ + {+RUNNER}; + + $self->SUPER::init(); + + delete $self->{+TERMINATED}; + + $self->{+RUN_ORDER} = []; # run-id's in order they should be run + $self->{+RUNS} = {}; # { run_id => {..., jobs => \@COMPLETE_LIST, jobs_todo => ..., jobs_complete => {}} } + $self->{+RUNNING} = {}; + $self->{+CHILDREN} = {}; # pid => ...? +} + +sub terminate { + my $self = shift; + my ($reason) = @_; + + $reason ||= 1; + + return $self->{+TERMINATED} ||= $reason; +} + +sub start { + my $self = shift; + my ($ipc) = @_; + $self->runner->start($self, $ipc); +} + +sub register_child { + my $self = shift; + my ($pid, $callback) = @_; + $self->{+CHILDREN}->{$pid} = $callback; +} + +sub queue_run { + my $self = shift; + my ($run) = @_; + + my $run_id = $run->run_id; + + croak "run id '$run_id' already in queue" if $self->{+RUNS}->{$run_id}; + + push @{$self->{+RUN_ORDER}} => $run_id; + $run = $self->{+RUNS}->{$run_id} = Test2::Harness::Scheduler::Default::Run->new(%$run); + + my $stamp = time; + + my $con = $run->connect; + $con->send_message({ + stamp => time, + event_id => gen_uuid, + run_id => $run->run_id, + facet_data => {harness_run => $run->data_no_jobs}, + }); + + for my $job (@{$run->jobs}) { + $con->send_message(Test2::Harness::Event->new( + event_id => gen_uuid, + run_id => $run->run_id, + job_id => $job->job_id, + job_try => $job->try, + stamp => time, + + facet_data => { + harness_job_queued => { + file => $job->test_file->file, + job_id => $job->job_id, + stamp => $stamp, + } + }, + )); + + $self->job_container($run->todo, $job, vivify => 1)->{$job->{job_id}} = $job; + } + + return $run_id; +} + +sub job_container { + my $self = shift; + croak "Insufficient arguments" unless @_; + $_[0] //= {}; + my ($cont, $job, %params) = @_; + + for my $step ($self->job_fields($job)) { + return unless exists($cont->{$step}) || $params{vivify}; + $cont = $cont->{$step} //= {}; + } + + return $cont; +} + +sub job_fields { + my $self = shift; + my ($job) = @_; + + my $tf = $job->test_file; + + my $smoke = $tf->check_feature('smoke') ? 'smoke' : 'main'; + + my $stage = $self->runner->job_stage($job, $tf->check_stage) // 'NONE'; + + my $cat = $tf->check_category // 'general'; + my $dur = $tf->check_duration // 'medium'; + + my $confl = @{$tf->conflicts_list // []} ? 'conflict' : 'none'; + + return ($smoke, $stage, $cat, $dur, $confl); +} + +sub wait_on_kids { + my $self = shift; + + local ($?, $!); + + while (1) { + my $pid = waitpid(-1, WNOHANG); + my $exit = $?; + + last if $pid < 1; + + my $cb = delete $self->{+CHILDREN}->{$pid} or die "Reaped untracked process!"; + $cb->(exit => $exit, scheduler => $self) if $cb && ref($cb) eq 'CODE'; + } +} + +sub finalize_completed_runs { + my $self = shift; + + my @run_order; + for my $run_id (@{$self->{+RUN_ORDER}}) { + my $run = $self->{+RUNS}->{$run_id} or next; + + my $todo = $run->todo; + hash_purge($todo); + + my $keep = 0; + unless ($run->halt) { + $keep ||= keys %$todo; + } + + $keep ||= keys %{$run->running}; + + if ($keep) { + push @run_order => $run_id; + next; + } + + $self->finalize_run($run_id); + } + + @{$self->{+RUN_ORDER}} = @run_order; +} + +sub finalize_run { + my $self = shift; + my ($run_id) = @_; + + my $run = delete $self->{+RUNS}->{$run_id} or return; + + return if eval { + $run->connect->send_message({ + run_complete => { + run_id => $run_id, + jobs => {map { ($_->job_id => $_->results) } @{$run->complete}}, + } + }); + + 1; + }; + + ipc_warn(error => $@); +} + +sub job_update { + my $self = shift; + my ($update) = @_; + + my $run_id = $update->{run_id}; + my $job_id = $update->{job_id}; + + my $run = $self->{+RUNS}->{$run_id} or die "Invalid run!"; + my $job = $run->job_lookup->{$job_id} or die "Invalid job!"; + + if (defined $update->{halt}) { + $run->set_halt($update->{halt} || 'halted'); + } + + if (my $pid = $update->{pid}) { + $self->{+RUNNING}->{jobs}->{$job_id}->{pid} = $pid; + } + + if (my $res = $update->{result}) { + push @{$job->{results}} => $res; + + warn "FIXME: retry"; + push @{$run->complete} => $job; + + my $info = delete $run->running->{$job->job_id}; + $info->{cleanup}->($self) if $info->{cleanup}; + } +} + +sub abort { + my $self = shift; + my (@runs) = @_; + + my %runs = map { $_ => $self->{+RUNS}->{$_} } @runs ? @runs : keys %{$self->{+RUNS} // {}}; + + for my $run (values %runs) { + $run->set_halt('aborted'); + } + + for my $job (values %{$self->{+RUNNING}->{jobs} // {}}) { + next unless $runs{$job->{run}->run_id}; + my $pid = $job->{pid} // next; + CORE::kill('TERM', $pid); + $job->{killed} = 1; + } +} + +sub kill { + my $self = shift; + $self->abort; +} + +sub manage_tests { + my $self = shift; + + for my $job_id (keys %{$self->{+RUNNING}->{jobs}}) { + my $job_data = $self->{+RUNNING}->{jobs}->{$job_id}; + + # Timeout if it takes too long to start + if (!$job_data->{pid}) { + my $delta = time - $job_data; + my $timeout = $self->runner->test_settings->event_timeout || 30; + + if ($delta > $timeout) { + warn "Job '$job_id' took too long to start, timing it out: " . encode_pretty_json($job_data->{job}); + my $info = delete $job_data->{run}->running->{$job_id}; + $info->{cleanup}->($self) if $info->{cleanup}; + } + } + + # Kill pid if run is terminated and it has a pid + if ($job_data->{run}->halt && !$job_data->{killed}) { + next unless $job_data->{pid}; + CORE::kill('TERM', $job_data->{pid}); + $job_data->{killed} = 1; + } + } +} + +sub advance { + my $self = shift; + + $self->finalize_completed_runs; + $self->wait_on_kids; + $self->manage_tests; + + return unless $self->runner->ready; + + my ($run, $job, $stage, $cat, $dur, $confl, $job_set) = $self->next_job() or return; + + my $ok = $self->runner->launch_job($stage, $run, $job); + + # If the job could not be started + unless ($ok) { + $job_set->{$job->job_id} = $job; + return 1; + } + + my $info = { + job => $job, + run => $run, + pid => undef, + start => time, + cleanup => sub { + my $scheduler = shift; + + $scheduler->{+RUNNING}->{categories}->{$cat}--; + $scheduler->{+RUNNING}->{durations}->{$dur}--; + $scheduler->{+RUNNING}->{conflicts}->{$_}-- for @{$confl || []}; + $scheduler->{+RUNNING}->{total}--; + + # The next several bits are to avoid memory leaks + my $info1 = delete $run->running->{$job->job_id}; + my $info2 = delete $self->{+RUNNING}->{jobs}->{$job->job_id}; + for my $info ($info1, $info2) { + next unless $info; + delete $info->{cleanup}; + delete $info->{job}; + } + $job = undef; + $run = undef; + }, + }; + + $run->running->{$job->job_id} = $info; + $self->{+RUNNING}->{jobs}->{$job->job_id} = $info; + + $self->{+RUNNING}->{categories}->{$cat}++; + $self->{+RUNNING}->{durations}->{$dur}++; + $self->{+RUNNING}->{conflicts}->{$_}++ for @{$confl || []}; + $self->{+RUNNING}->{total}++; + + return 1; +} + +sub category_order { + my $self = shift; + + my @cat_order = ('conflicts', 'general'); + + my $running = $self->running; + + # Only search immiscible if we have no immiscible running + # put them first if no others are running so we can churn through them + # early instead of waiting for them to run 1 at a time at the end. + unshift @cat_order => 'immiscible' unless $running->{categories}->{immiscible}; + + # Only search isolation if nothing is running. + unshift @cat_order => 'isolation' unless $running->{total}; + + return \@cat_order; +} + +sub duration_order { [qw/long medium short/] } + +sub next_job { + my $self = shift; + + my $running = $self->{+RUNNING}; + + my $stages = $self->runner->stage_sets; + my $cat_order = $self->category_order; + my $dur_order = $self->duration_order; + + for my $run_id (@{$self->{+RUN_ORDER}}) { + my $run = $self->{+RUNS}->{$run_id}; + next if $run->halt; + my $search = $run->todo or next; + + for my $smoke (qw/smoke main/) { + my $search = $search->{$smoke} or next; + + for my $stage_set (@$stages) { + my ($lstage, $run_by_stage) = @$stage_set; + my $search = $search->{$lstage} or next; + + for my $cat (@$cat_order) { + my $search = $search->{$cat} or next; + + for my $dur (@$dur_order) { + my $search = $search->{$dur} or next; + + for my $confl (qw/conflict none/) { + my $search = $search->{$confl} or next; + + for my $job_id (keys %$search) { + my $job = $search->{$job_id}; + + # Skip if conflicting tests are running + my $confl = $job->test_file->conflicts_list; + next if first { $running->{conflicts}->{$_} } @$confl; + + delete $search->{$job_id}; + return ($run, $job, $run_by_stage, $cat, $dur, $confl, $search); + } + } + } + } + } + } + } + + return; +} + +sub DESTROY { + my $self = shift; + + $self->terminate('DESTROY'); +} + +1; + + +__END__ +use Carp qw/croak confess/; +use List::Util qw/first/; +use Scalar::Util qw/blessed/; +use Time::HiRes qw/time/; +use Test2::Harness::Util qw/mod2file/; +use Linux::Inotify2; + +use Test2::Harness::Task; + +use parent 'Test2::Harness::IPC::Util::TxnState::Shared'; +use Test2::Harness::Util::HashBase qw{ + SUPER::init(); + + $self->{+RUNS} //= {}; + $self->{+PENDING} //= {}; + $self->{+RUNNING} //= {}; + $self->{+RUN_ORDER} //= []; +} + +sub post_data_hook { + my $self = shift; + + my $pending = $self->{+PENDING}; + + for my $run_id (keys %{$pending // {}}) { + for my $test (@{$pending->{$run_id} // []}) { + Test2::Harness::Task->FROM_JSON($test) unless blessed($test); + } + } + + return $self; +} + +sub queue { + my $self = shift; + my ($run_id) = @_; + + $self->transaction(w => sub { + confess "run '$run_id' has already been queued" + if $self->{+RUNS}->{$run_id}; + + confess "Queue has been terminated" + if @{$self->{+RUN_ORDER}} && !defined($self->{+RUN_ORDER}->[-1]); + + push @{$self->{+RUN_ORDER} //= []} => $run_id; + $self->{+RUNS}->{$run_id} = 1; + + my $pending = $self->{+PENDING} //= {}; + + for my $task (@{$self->sort_tasks($self->state->shared_all([task => $run_id]))}) { + if ($task->is_test) { + push @{$pending->{$run_id}} => $task->state_field; + } + else { + $self->state->shared_get('runner', $task->stage)->queue_job($task->state_field); + } + } + }); +} + +sub retry { + my $self = shift; + my ($task) = @_; + + confess "rerun can only be used for test tasks" unless $task->is_test; + + my $run_id = $task->run_id or die "No run id"; + my $run = $self->runs->{$run_id} or confess "Invalid run_id '$run_id', run not found"; + + $task = $task->clone; + $task->increment_try; + + $task->set_category('isolation') if $run->retry_isolated; + + $self->transaction(w => sub { + my $pending = $self->{+PENDING} //= {}; + unshift @{$pending->{$run_id}} => $task->state_field; + }); +} + +my %CAT_ORDER = ( + isolation => 1, + immiscible => 2, + conflicts => 3, + general => 4, +); + +my %DURATION_ORDER = ( + long => 1, + medium => 2, + short => 3, +); + +sub sort_tasks { + my $self = shift; + my ($tasks) = @_; + + @$tasks = sort { + my $out = 0; + + $out ||= $a->is_test <=> $b->is_test; + + # Retries to the front + $out ||= $b->is_try <=> $a->is_try; + + # Smoke early + $out ||= $b->smoke <=> $a->smoke; + + # Categegories by order + $out ||= $CAT_ORDER{$a->category} <=> $CAT_ORDER{$b->category}; + + # More Conflicts means run earlier + $out ||= @{$b->conflicts // []} <=> @{$a->conflicts // []}; + + # Duration if possible + my $ad = $a->duration; + my $bd = $b->duration; + if ($ad && $bd) { + $ad = lc($ad); + $bd = lc($bd); + + if ($DURATION_ORDER{$ad} && $DURATION_ORDER{$bd}) { + $out = $DURATION_ORDER{$ad} <=> $DURATION_ORDER{$bd}; + } + else { + $out = $ad <=> $bd; + } + } + + $out; + } @$tasks; + + return $tasks; +} + +sub terminate_queue { + my $self = shift; + + $self->transaction(w => sub { + return if @{$self->{+RUN_ORDER} // []} && !defined($self->{+RUN_ORDER}->[-1]); + push @{$self->{+RUN_ORDER} //= []} => undef; + }); +} + +sub truncate_queue { + my $self = shift; + my (%params) = @_; + + $self->transaction(w => sub { + $self->{+RUN_ORDER} = []; + $self->{+RUNS} = {}; + $self->{+PENDING} = {}; + + if ($params{terminate}) { + push @{$self->{+RUN_ORDER} //= []} => undef; + $self->{+DONE} = 1; + } + }); +} + +sub before_write { shift->unwatch } +sub after_write { shift->watch } + +sub inotify { + my $self = shift; + $self->{+INOTIFY} //= my $inotify = Linux::Inotify2->new or $self->harness->abort("Could not initialize Linux::Inotify2: $!"); + return $self->{+INOTIFY}; +} + +sub watch { + my $self = shift; + + return $self->{+WATCH} if $self->{+WATCH}; + + print "Adding Watch\n"; + + my $inotify = $self->inotify; + my $harness = $self->state; + $self->{+WATCH} = $inotify->watch($harness->state_file, IN_MODIFY | IN_ONESHOT, sub { $self->iterate($inotify) }) or $harness->abort("Could not watch state file: $!"); + return $self->{+WATCH}; +} + +sub unwatch { + my $self = shift; + + print "Canceling Watch\n"; + + my $watch = $self->{+WATCH} or return; + $watch->cancel; +} + +sub run { + my $self = shift; + + if (my $run_pid = $self->{+RUN_PID}) { + confess "Only pid '$run_pid' can run the scheduler, this is pid '$$'" unless $$ == $run_pid; + confess "Scheduler is already running"; + } + else { + $self->transaction(w => sub { $self->{+RUN_PID} = $$ }); + } + + print "STATE: " . $self->state->state_file . "\n"; + + my $child = 0; + local $SIG{CHLD} = sub { $child++; }; # Required to break inotify poll + + while(1) { + print "LOOP!\n"; + $self->iterate(); + last if $self->done; + $self->inotify->poll; + last if $self->done; + } + + $self->transaction(w => sub { delete $self->{+RUN_PID} }); + + return 0; +} + +sub ready_stages { + my $self = shift; + + my $harness = $self->state; + + my %ready; + + $self->transaction(r => sub { + %ready = map { my $n = $_->stage_name; ($n => $n) } grep { $_->ready } @{$harness->shared_all('runners')}; + }); + + my $base = $harness->shared_get(runner => 'base'); + + my %out; + + # This will iterate all stages and their children. Any ready eager stage + # found will be set as the value of it's child stages in the %out hash. + # This will make the deepest ready-eager stage the assigned value for any + # child stage. + my %seen; + my @todo = @{$base->children}; + while (my $s = shift @todo) { + next if $seen{$s}++; + + my $name = $s->name; + my $e = $s->eager; + + for my $child (@{$s->children}) { + push @todo => $child; + next unless $e && $ready{$name}; + + my $cname = $child->name; + $out{$cname} = $name; + } + } + + # Use our eager stages, but override with ready stages where applicable. + # 'base' is always ready + return {%out, %ready, base => 'base'}; +} + +sub iterate { + my $self = shift; + print "ITERATE\n"; + + my $runner = $self->state->shared_get('runner', 'base'); + + if (!$runner->is_running && defined $runner->exit_code) { + $self->{+DONE} = 1; + return; + } + + return if $self->done; + + $self->refresh; + return if $self->done; + + # If there are no runs to do then we do nothing + my $run_order = $self->run_order; + return unless $run_order && @$run_order; + + # Only run is undef, that means we have terminated the queue, and we have + # completed all runs up until the termination + if (@$run_order && !defined($run_order->[0])) { + $self->{+DONE} = 1; + return; + } + + return unless $self->pending; + my $harness = $self->state; + my $runs = $self->runs; + my @limiters = grep { $_->is_job_limiter || $_->applies_to_all_tests } @{$self->state->shared_all('resources')}; + + my $hit_limit = 0; + my $limited = sub { + return 1 if $hit_limit; + $hit_limit = first { !$_->available } @limiters; + }; + + my $stages = $self->ready_stages; + + for my $run_id (@$run_order) { + last unless $run_id; + return if $limited->(); + + # If any 'isolated' test is running, then we cannot do anything. + last if $self->{+RUNNING}->{categories}->{isolation}; + + my $run = $runs->{$run_id} or confess "No run found for run-id '$run_id'"; + + my $isolation = 0; + + $self->transaction( + w => sub { + my $pending = $self->pending; + my $run_pending = $pending->{$run_id} //= []; + + my @keep; + while (my $task_id = shift @$run_pending) { + push @keep => $task_id; + my $test = $harness->shared_get(@$task_id); + + last if $limited->(); # Do not make this one return. + + $isolation++ if $test->category eq 'isolation'; + + my $spec = $self->can_run($test, $stages) or next; + pop @keep; # We will handle it now + + if (my $unavailable = $spec->{unavailable}) { + use Data::Dumper; + print "SKIP: $test->{file} " . Dumper($spec); + $runner->skip_test($test, $unavailable); + } + else { + print "RUN: $test->{file}\n"; + my $stage = $spec->{stage}; + my $task = $spec->{task}; + print $task->{file} . "\n"; + $self->start_running($task); + my $runner = $self->state->shared_get(runner => $stage); + $runner->queue_task($task); + } + } + + unshift @$run_pending => @keep; + } + ); + + return if $limited->(); + + # Do not progress to the next run if there are isolation tests that + # need to execute. We might never finish this run if we do. + return if $isolation; + } +} + +sub can_run { + my $self = shift; + my ($test, $stages) = @_; + + # Do not run if there is a conflict + my $conflicts = $self->{+RUNNING}->{conflicts}; + return if first { $conflicts->{$_} } @{$test->conflicts}; + + # Do not run if isolation is not right + return if $self->{+RUNNING}->{categories}->{isolation}; + return if $test->category eq 'isolation' && $self->{+RUNNING}->{total}; + + # Do not run if no stage can run it + # We need a list of stages, as well as what stages they can emulate (early-eager) + my $stage = $stages->{$test->stage} or return; + + # Resource check+assignment + my @resources = @{$self->state->shared_all('resource')}; + + my (@free, @busy, @unavailable); + for my $res (@resources) { + next unless $res->is_job_limiter || $res->applies_to_all_tests || $res->applies_to_test($test); + my $av = $res->available_for_test($test); + + if ($av) { # Available + push @free => [$res, $av]; + } + elsif (!defined($av)) { # Will never be available + push @unavailable => $res; + } + else { # Busy, try again + push @busy => $res; + } + } + + return {unavailable => \@unavailable} if @unavailable; + + return if @busy; + + my $env = {}; + for my $res_set (@free) { + my ($res, $av) = @$res_set; + $res->allocate_for_test($test, $av, env => $env); + } + + my $task = $test->clone; + $task->set_env_vars({%{$task->env_vars // {}}, %$env}); + + return {stage => $stage, task => $task}; +} + +sub start_running { + my $self = shift; + my ($task) = @_; + + $self->transaction(w => sub { + $self->{+RUNNING}->{by_job_id}->{$task->job_id} = $task; + $self->{+RUNNING}->{total}++; + $self->{+RUNNING}->{by_run_id}->{$task->run_id}++; + $self->{+RUNNING}->{categories}->{$task->category}++; + $self->{+RUNNING}->{conflicts}->{$_}++ for @{$task->conflicts}; + }); +} + +sub stop_running { + my $self = shift; + my ($task, %params) = @_; + + $self->transaction(w => sub { + delete $self->{+RUNNING}->{by_job_id}->{$task->job_id}; + $self->{+RUNNING}->{total}--; + $self->{+RUNNING}->{by_run_id}->{$task->run_id}--; + $self->{+RUNNING}->{categories}->{$task->category}--; + $self->{+RUNNING}->{conflicts}->{$_}-- for @{$task->conflicts // []}; + + $self->retry($task) if $params{retry}; + }); +} + +sub category_order { + my $self = shift; + + my @cat_order = ('conflicts', 'general'); + + my $running = $self->running; + + # Only search immiscible if we have no immiscible running + # put them first if no others are running so we can churn through them + # early instead of waiting for them to run 1 at a time at the end. + unshift @cat_order => 'immiscible' unless $running->{categories}->{immiscible}; + + # Only search isolation if nothing is running. + unshift @cat_order => 'isolation' unless $running->{total}; + + return \@cat_order; +} + +sub TO_JSON { + my $self = shift; + my $out = $self->SUPER::TO_JSON(); + delete $out->{+INOTIFY}; + delete $out->{+WATCH}; + return $out; +} + +1; + +__END__ + + +my %SORTED; +sub _next { + my $self = shift; + + my $run = $self->{+RUN} or return; + my $run_id = $run->run_id; + + my $pending = $self->{+PENDING_TASKS}->{$run_id} or return; + + my $conflicts = $self->{+RUNNING_CONFLICTS}; + my $cat_order = $self->_cat_order; + my $dur_order = $self->_dur_order; + my $stages = $self->_stage_order(); + my $resources = $self->{+RESOURCES}; + + # Ugly.... + my $search = $pending; + + for my $smoke (qw/smoke main/) { + my $search = $search->{$smoke} or next; + + for my $stage_set (@$stages) { + my ($lstage, $run_by_stage) = @$stage_set; + my $search = $search->{$lstage} or next; + + for my $lcat (@$cat_order) { + my $search = $search->{$lcat} or next; + + for my $ldur (@$dur_order) { + my $search = $search->{$ldur} or next; + + # Make sure anything with conflicts runs early. + unless ($SORTED{$search}++) { + @$search = sort { scalar(@{$b->{conflicts}}) <=> scalar(@{$a->{conflicts}}) } @$search; + } + + for my $task (@$search) { + # If the job has a listed conflict and an existing job is running with that conflict, then pick another job. + next if first { $conflicts->{$_} } @{$task->{conflicts}}; + + my $ok = 1; + my @resource_skip; + for my $resource (@$resources) { + my $out = $resource->available($task) || 0; # normalize false to 0 + + push @resource_skip => ref($resource) || $resource if $out < 0; + + $ok &&= $out; + + # If we have a temporarily unavailable resource we + # skip, but if any resource is never avilable + # (skip) we want to finish the loop to add them all + # for the skip message. + last if !$ok && !@resource_skip; + } + + # Some resource is temporarily not available + next unless $ok; + + my $outres = {args => [], env_vars => {}, record => {}}; + + my @out = ($run_by_stage => $task, $outres); + + my @record = @$resources; + + if (@resource_skip) { + push @out => (resource_skip => \@resource_skip); + + # Only the job limiter resources need to be recorded. + @record = grep { $_->job_limiter } @record; + } + + for my $resource (@record) { + my $res = {args => [], env_vars => {}}; + $resource->assign($task, $res); + push @{$outres->{args}} => @{$res->{args}}; + $outres->{env_vars}->{$_} = $res->{env_vars}->{$_} for keys %{$res->{env_vars}}; + $outres->{record}->{ref($resource)} = $res->{record}; + } + + return @out; + } + } + } + } + } + + return; +} + +package Test2::Harness::Runner::State; +use strict; +use warnings; + +our $VERSION = '1.000152'; + +use Carp qw/croak/; + +use File::Spec; +use Time::HiRes qw/time/; +use List::Util qw/first/; + +use Test2::Harness::Util qw/mod2file/; + +use Test2::Harness::State; + +use Test2::Harness::Settings; +use Test2::Harness::Runner::Constants; + +use Test2::Harness::Runner::Run; +use Test2::Harness::Util::Queue; + +use Test2::Harness::Util::UUID qw/gen_uuid/; + +use Test2::Harness::Util::HashBase( + # These are construction arguments + qw{ + {+STATE} || defined $self->{+WORKDIR}; + + $self->{+WORKDIR} //= $self->{+STATE}->workdir; + $self->{+STATE} //= Test2::Harness::State->new(workdir => $self->{+WORKDIR}); + + $self->{+JOB_COUNT} //= $self->settings->runner->job_count // 1; + + if (!$self->{+RESOURCES} || !@{$self->{+RESOURCES}}) { + my $settings = $self->settings; + my $resources = $self->{+RESOURCES} //= []; + for my $res (@{$self->settings->runner->resources}) { + require(mod2file($res)); + push @$resources => $res->new(settings => $self->settings, observe => $self->{+OBSERVE}); + } + } + + unless (grep { $_->job_limiter } @{$self->{+RESOURCES}}) { + require Test2::Harness::Runner::Resource::JobCount; + push @{$self->{+RESOURCES}} => Test2::Harness::Runner::Resource::JobCount->new(job_count => $self->{+JOB_COUNT}, settings => $self->settings); + } + + @{$self->{+RESOURCES}} = sort { $a->sort_weight <=> $b->sort_weight } @{$self->{+RESOURCES}}; + + $self->{+DISPATCH_FILE} = Test2::Harness::Util::Queue->new(file => File::Spec->catfile($self->{+WORKDIR}, 'dispatch.jsonl')); + + $self->{+RELOAD_STATE} //= {}; + + $self->poll; +} + +sub settings { + my $self = shift; + return $self->{+SETTINGS} //= $self->state->settings; +} + +sub run { + my $self = shift; + return $self->{+RUN} if $self->{+RUN}; + $self->poll(); + return $self->{+RUN}; +} + +sub done { + my $self = shift; + + $self->poll(); + + return 0 if $self->{+RUNNING}; + return 0 if keys %{$self->{+PENDING_TASKS} //= {}}; + + return 0 if $self->{+RUN}; + return 0 if @{$self->{+PENDING_RUNS} //= []}; + + return 0 unless $self->{+QUEUE_ENDED}; + + return 1; +} + +sub next_task { + my $self = shift; + my ($stage) = @_; + + $self->poll(); + $self->clear_finished_run(); + + while(1) { + if (@{$self->{+PENDING_SPAWNS} //= []}) { + my $spawn = shift @{$self->{+PENDING_SPAWNS}}; + next unless $spawn->{stage} eq $stage; + $self->start_spawn($spawn); + return $spawn; + } + + my $task = shift @{$self->{+TASK_LIST}} or return undef; + + # If we are replaying a state then the task may have already completed, + # so skip it if it is not in the running lookup. + next unless $self->{+RUNNING_TASKS}->{$task->{job_id}}; + next unless $task->{stage} eq $stage; + + return $task; + } +} + +sub advance { + my $self = shift; + $self->poll(); + + $_->tick() for @{$self->{+RESOURCES} //= []}; + + $self->advance_run(); + return 0 unless $self->{+RUN}; + return 1 if $self->advance_tasks(); + return $self->clear_finished_run(); +} + +my %ACTIONS = ( + queue_run => '_queue_run', + queue_task => '_queue_task', + queue_spawn => '_queue_spawn', + start_spawn => '_start_spawn', + start_run => '_start_run', + start_task => '_start_task', + stop_run => '_stop_run', + stop_task => '_stop_task', + retry_task => '_retry_task', + stage_ready => '_stage_ready', + stage_down => '_stage_down', + end_queue => '_end_queue', + halt_run => '_halt_run', + truncate => '_truncate', + reload => '_reload', +); + +sub poll { + my $self = shift; + + return if $self->{+NO_POLL}; + + my $queue = $self->dispatch_file; + + for my $item ($queue->poll) { + my $data = $item->[-1]; + my $item = $data->{item}; + my $action = $data->{action}; + my $pid = $data->{pid}; + + my $sub = $ACTIONS{$action} or die "Invalid action '$action'"; + + $self->$sub($item, $pid); + } +} + +sub _enqueue { + my $self = shift; + my ($action, $item) = @_; + $self->{+DISPATCH_FILE}->enqueue({action => $action, item => $item, stamp => time, pid => $$}); + $self->poll; +} + +sub truncate { + my $self = shift; + $self->halt_run($_) for keys %{$self->{+PENDING_TASKS} // {}}; + $self->_enqueue(truncate => $$); + $self->poll; +} + +sub _truncate { } + +sub end_queue { $_[0]->_enqueue('end_queue' => 1) } +sub _end_queue { $_[0]->{+QUEUE_ENDED} = 1 } + +sub halt_run { + my $self = shift; + my ($run_id) = @_; + $self->_enqueue(halt_run => $run_id); + + $self->state->transaction(w => sub { + my ($state, $data) = @_; + return unless exists $data->jobs->{$run_id}; + $data->jobs->{$run_id}->{closed} = 1; + }); +} + +sub _halt_run { + my $self = shift; + my ($run_id) = @_; + + delete $self->{+PENDING_TASKS}->{$run_id}; + + $self->{+HALTED_RUNS}->{$run_id}++; +} + +sub queue_run { + my $self = shift; + my ($run) = @_; + $self->_enqueue(queue_run => $run); +} + +sub _queue_run { + my $self = shift; + my ($run) = @_; + + push @{$self->{+PENDING_RUNS}} => Test2::Harness::Runner::Run->new( + %$run, + workdir => $self->{+WORKDIR}, + state => $self->{+STATE}, + ); + + return; +} + +sub start_run { + my $self = shift; + my ($run_id) = @_; + $self->_enqueue(start_run => $run_id); +} + +sub _start_run { + my $self = shift; + my ($run_id) = @_; + + my $run = shift @{$self->{+PENDING_RUNS}}; + die "$0 - Run stack mismatch, run start requested, but no pending runs to start" unless $run; + die "$0 - Run stack mismatch, run-id does not match next pending run" unless $run->run_id eq $run_id; + + $self->{+RUN} = $run; + + return; +} + +sub stop_run { + my $self = shift; + my ($run_id) = @_; + $self->_enqueue(stop_run => $run_id); +} + +sub _stop_run { + my $self = shift; + my ($run_id) = @_; + + $self->{+STOPPED_RUNS}->{$run_id} = 1; + + return; +} + +sub queue_spawn { + my $self = shift; + my ($spawn) = @_; + $spawn->{spawn} //= 1; + $spawn->{id} //= gen_uuid(); + $self->_enqueue(queue_spawn => $spawn); +} + +sub _queue_spawn { + my $self = shift; + my ($spawn) = @_; + + $spawn->{id} //= gen_uuid(); + $spawn->{spawn} //= 1; + $spawn->{use_preload} //= 1; + + $spawn->{stage} //= 'default'; + $spawn->{stage} = $self->task_stage($spawn); + + push @{$self->{+PENDING_SPAWNS}} => $spawn; + + return; +} + +sub start_spawn { + my $self = shift; + my ($spec) = @_; + $self->_enqueue(start_spawn => $spec); +} + +sub _start_spawn { + my $self = shift; + my ($spec) = @_; + + my $uuid = $spec->{id} or die "Could not find UUID for spawn"; + + @{$self->{+PENDING_SPAWNS}} = grep { $_->{id} ne $uuid } @{$self->{+PENDING_SPAWNS}}; + + return; +} + +sub queue_task { + my $self = shift; + my ($task) = @_; + $self->_enqueue(queue_task => $task); +} + +sub _queue_task { + my $self = shift; + my ($task) = @_; + + my $job_id = $task->{job_id} or die "Task missing job_id"; + my $run_id = $task->{run_id} or die "Task missing run_id"; + + die "Task already in queue" if $self->{+TASK_LOOKUP}->{$job_id}; + + return if $self->{+HALTED_RUNS}->{$run_id}; + + $self->{+TASK_LOOKUP}->{$job_id} = $task; + + my $pending = $self->task_pending_lookup($task); + push @{$pending} => $task; + + return; +} + +sub start_task { + my $self = shift; + my ($spec) = @_; + $self->_enqueue(start_task => $spec); +} + +sub _start_task { + my $self = shift; + my ($spec) = @_; + + my $job_id = $spec->{job_id} or die "No job_id provided"; + my $run_stage = $spec->{stage} or die "No stage provided"; + my $res = $spec->{res} or die "No res provided"; + my $res_skip = $spec->{resource_skip}; + + my $task = $self->{+TASK_LOOKUP}->{$job_id} or die "Could not find task to start"; + + my ($run_id, $smoke, $stage, $cat, $dur) = $self->task_fields($task); + + my $set = $self->{+PENDING_TASKS}->{$run_id}->{$smoke}->{$stage}->{$cat}->{$dur}; + my $count = @$set; + @$set = grep { $_->{job_id} ne $job_id } @$set; + die "Task $job_id was not pending ($count -> " . scalar(@$set) . ")" unless $count > @$set; + + $self->prune_hash($self->{+PENDING_TASKS}, $run_id, $smoke, $stage, $cat, $dur); + + # Set the stage, new task hashref + $task = {%$task, stage => $run_stage} unless $task->{stage} && $task->{stage} eq $run_stage; + + $task->{env_vars}->{$_} = $res->{env_vars}->{$_} for keys %{$res->{env_vars}}; + push @{$task->{test_args}} => @{$res->{args}}; + + for my $resource (@{$self->{+RESOURCES}}) { + my $class = ref($resource); + my $val = $res->{record}->{$class} // next; + $resource->record($task->{job_id}, $val); + } + + die "Already running task $job_id" if $self->{+RUNNING_TASKS}->{$job_id}; + $self->{+RUNNING_TASKS}->{$job_id} = $task; + + $task->{resource_skip} = $res_skip if $res_skip; + + push @{$self->{+TASK_LIST}} => $task; + + $self->{+RUNNING}++; + $self->{+RUNNING_CATEGORIES}->{$cat}++; + $self->{+RUNNING_DURATIONS}->{$dur}++; + + my $cfls = $task->{conflicts} //= []; + for my $cfl (@$cfls) { + die "Unexpected parallel conflict '$cfl' ($self->{+RUNNING_CONFLICTS}->{$cfl}) running at this time!" + if $self->{+RUNNING_CONFLICTS}->{$cfl}++; + } + + return; +} + +sub stop_task { + my $self = shift; + my ($job_id) = @_; + $self->_enqueue(stop_task => $job_id); +} + +sub _stop_task { + my $self = shift; + my ($job_id) = @_; + + my $task = delete $self->{+TASK_LOOKUP}->{$job_id} or die "Could not find task to stop ($job_id)"; + + delete $self->{+RUNNING_TASKS}->{$job_id} or die "Task is not running, cannot stop it ($job_id)"; + + $_->release($job_id) for @{$self->{+RESOURCES}}; + + my ($run_id, $smoke, $stage, $cat, $dur) = $self->task_fields($task); + $self->{+RUNNING}--; + $self->{+RUNNING_CATEGORIES}->{$cat}--; + $self->{+RUNNING_DURATIONS}->{$dur}--; + + my $cfls = $task->{conflicts} //= []; + $self->{+RUNNING_CONFLICTS}->{$_}-- for @$cfls; + + return; +} + +sub retry_task { + my $self = shift; + my ($job_id) = @_; + + $self->_enqueue(retry_task => $job_id); +} + +sub _retry_task { + my $self = shift; + my ($job_id) = @_; + + my $task = $self->{+TASK_LOOKUP}->{$job_id} or die "Could not find task to retry"; + + $self->_stop_task($job_id); + + return if $self->{+HALTED_RUNS}->{$task->{run_id}}; + + $task = {is_try => 0, %$task}; + $task->{is_try}++; + $task->{category} = 'isolation' if $self->{+RUN}->retry_isolated; + + $self->_queue_task($task); + + return; +} + +sub stage_ready { + my $self = shift; + my ($stage) = @_; + $self->_enqueue(stage_ready => $stage); +} + +sub _stage_ready { + my $self = shift; + my ($stage, $pid) = @_; + + $self->{+STAGE_READINESS}->{$stage} = $pid // 1; + + return; +} + +sub stage_down { + my $self = shift; + my ($stage) = @_; + $self->_enqueue(stage_down => $stage); +} + +sub _stage_down { + my $self = shift; + my ($stage) = @_; + + $self->{+STAGE_READINESS}->{$stage} = 0; + + return; +} + +sub reload { + my $self = shift; + my ($stage, $data) = @_; + $stage //= 'default'; + $self->_enqueue(reload => {%$data, stage => $stage}); + return; +} + +sub _reload { + my $self = shift; + my ($data) = @_; + + my $stage = $data->{stage}; + my $file = $data->{file}; + my $success = $data->{reloaded}; + my $error = $data->{error}; + my $warnings = $data->{warnings}; + + my $reload_state = $self->{+RELOAD_STATE} //= {}; + my $stage_state = $reload_state->{$stage} //= {}; + + # It either succeeded, or the stage will be reloaded, no need to track brokenness + if (defined $success) { + delete $stage_state->{$file}; + } + else { + my $fields = {}; + $fields->{error} = $error if defined($error) && length($error); + $fields->{warnings} = $warnings if $warnings && @{$warnings}; + + if (keys %$fields) { + $stage_state->{$file} = $fields; + } + else { + delete $stage_state->{$file}; + } + } + + return; +} + +sub task_stage { + my $self = shift; + my ($task) = @_; + + my $wants = $task->{stage}; + $wants //= 'NOPRELOAD' unless $task->{use_preload}; + + return $wants if $self->{+NO_POLL}; + + return $wants // 'DEFAULT' unless $self->preloader; + return $self->preloader->task_stage($task->{file}, $wants); +} + +sub task_pending_lookup { + my $self = shift; + my ($task) = @_; + + my ($run_id, $smoke, $stage, $cat, $dur) = $self->task_fields($task); + + return $self->{+PENDING_TASKS}->{$run_id}->{$smoke}->{$stage}->{$cat}->{$dur} //= []; +} + +sub task_fields { + my $self = shift; + my ($task) = @_; + + my $run_id = $task->{run_id} or die "No run id provided by task"; + my $smoke = $task->{smoke} ? 'smoke' : 'main'; + my $stage = $self->task_stage($task); + + my $cat = $task->{category}; + my $dur = $task->{duration}; + + die "Invalid category: $cat" unless CATEGORIES->{$cat}; + die "Invalid duration: $dur" unless DURATIONS->{$dur}; + + $cat = 'conflicts' if $cat eq 'general' && $task->{conflicts} && @{$task->{conflicts}}; + + return ($run_id, $smoke, $stage, $cat, $dur); +} + +sub advance_run { + my $self = shift; + + return 0 if $self->{+RUN}; + + return 0 unless @{$self->{+PENDING_RUNS} //= []}; + $self->start_run($self->{+PENDING_RUNS}->[0]->run_id); + + return 1; +} + +sub clear_finished_run { + my $self = shift; + + my $run = $self->{+RUN} or return 0; + + return 0 unless $self->{+STOPPED_RUNS}->{$run->run_id}; + return 0 if $self->{+PENDING_TASKS}->{$run->run_id}; + return 0 if $self->{+RUNNING}; + + delete $self->{+RUN}; + $self->{+STATE}->transaction(w => sub { + my ($state, $data) = @_; + return unless exists $data->jobs->{$run->run_id}; + $data->jobs->{$run->run_id}->{closed} = 1; + }); + + return 1; +} + +sub advance_tasks { + my $self = shift; + + for my $resource (@{$self->{+RESOURCES}}) { + $resource->refresh(); + + next unless $resource->job_limiter; + return 0 if $resource->job_limiter_at_max(); + } + + my ($run_stage, $task, $res, %params) = $self->_next(); + + my $out = 0; + if ($task) { + $out = 1; + $self->start_task({job_id => $task->{job_id}, stage => $run_stage, res => $res, %params}); + } + + $_->discharge() for @{$self->{+RESOURCES}}; + + return $out; +} + +sub _cat_order { + my $self = shift; + + my @cat_order = ('conflicts', 'general'); + + # Only search immiscible if we have no immiscible running + # put them first if no others are running so we can churn through them + # early instead of waiting for them to run 1 at a time at the end. + unshift @cat_order => 'immiscible' unless $self->{+RUNNING_CATEGORIES}->{immiscible}; + + # Only search isolation if nothing is running. + push @cat_order => 'isolation' unless $self->{+RUNNING}; + + return \@cat_order; +} + +sub _dur_order { + my $self = shift; + + my $max = 0; + for my $resource (@{$self->resources}) { + next unless $resource->job_limiter; + my $val = $resource->job_limiter_max; + $max = $val if !$max || $val < $max; + } + $max //= 1; + + my $maxm1 = $max - 1; + + my $durs = $self->{+RUNNING_DURATIONS}; + + # 'short' is always ok. + my @dur_order = ('short'); + + # long and medium should be on the front of the search unless we are + # already running (max - 1) tests of the duration We want long first if + # we are not saturation on them, followed by medium, whcih is why they + # are listed in this order. + for my $c (qw/medium long/) { + if ($durs->{$c} && $durs->{$c} >= $maxm1) { + push @dur_order => $c; # Back of the list + } + else { + unshift @dur_order => $c; # Front of the list + } + } + + return \@dur_order; +} + +# This returns a list of [STAGE => RUN_STAGE] pairs. 'STAGE' is the stage in +# which we search for tasks, 'RUN_STAGE' is the stage that actually does the +# work. This is what allows us to find tasks for 'eager' stages that are bored. +sub _stage_order { + my $self = shift; + + my $stage_check = $self->{+STAGE_READINESS} //= {}; + + my @stage_list = sort grep { $stage_check->{$_} } keys %$stage_check; + + # Populate list with all ready stages + my %seen; + my @stages = map {[$_ => $_]} grep { !$seen{$_}++ } @stage_list; + + # Add in any eager stages, but make sure they are last. + for my $rstage (@stage_list) { + next unless exists $self->{+EAGER_STAGES}->{$rstage}; + push @stages => map {[$_ => $rstage]} grep { !$seen{$_}++ } @{$self->{+EAGER_STAGES}->{$rstage}}; + } + + return \@stages; +} + +my %SORTED; +sub _next { + my $self = shift; + + my $run = $self->{+RUN} or return; + my $run_id = $run->run_id; + + my $pending = $self->{+PENDING_TASKS}->{$run_id} or return; + + my $conflicts = $self->{+RUNNING_CONFLICTS}; + my $cat_order = $self->_cat_order; + my $dur_order = $self->_dur_order; + my $stages = $self->_stage_order(); + my $resources = $self->{+RESOURCES}; + + # Ugly.... + my $search = $pending; + + for my $smoke (qw/smoke main/) { + my $search = $search->{$smoke} or next; + + for my $stage_set (@$stages) { + my ($lstage, $run_by_stage) = @$stage_set; + my $search = $search->{$lstage} or next; + + for my $lcat (@$cat_order) { + my $search = $search->{$lcat} or next; + + for my $ldur (@$dur_order) { + my $search = $search->{$ldur} or next; + + # Make sure anything with conflicts runs early. + unless ($SORTED{$search}++) { + @$search = sort { scalar(@{$b->{conflicts}}) <=> scalar(@{$a->{conflicts}}) } @$search; + } + + for my $task (@$search) { + # If the job has a listed conflict and an existing job is running with that conflict, then pick another job. + next if first { $conflicts->{$_} } @{$task->{conflicts}}; + + my $ok = 1; + my @resource_skip; + for my $resource (@$resources) { + my $out = $resource->available($task) || 0; # normalize false to 0 + + push @resource_skip => ref($resource) || $resource if $out < 0; + + $ok &&= $out; + + # If we have a temporarily unavailable resource we + # skip, but if any resource is never avilable + # (skip) we want to finish the loop to add them all + # for the skip message. + last if !$ok && !@resource_skip; + } + + # Some resource is temporarily not available + next unless $ok; + + my $outres = {args => [], env_vars => {}, record => {}}; + + my @out = ($run_by_stage => $task, $outres); + + my @record = @$resources; + + if (@resource_skip) { + push @out => (resource_skip => \@resource_skip); + + # Only the job limiter resources need to be recorded. + @record = grep { $_->job_limiter } @record; + } + + for my $resource (@record) { + my $res = {args => [], env_vars => {}}; + $resource->assign($task, $res); + push @{$outres->{args}} => @{$res->{args}}; + $outres->{env_vars}->{$_} = $res->{env_vars}->{$_} for keys %{$res->{env_vars}}; + $outres->{record}->{ref($resource)} = $res->{record}; + } + + return @out; + } + } + } + } + } + + return; +} + +1; + +__END__ + + +=pod + +=encoding UTF-8 + +=head1 NAME + +Test2::Harness::Runner::State - State tracking for the runner. + +=head1 DESCRIPTION + +This module tracks the state for all running tests. This entire module is +considered an "Implementation Detail". Please do not rely on it always staying +the same, or even existing in the future. Do not use this directly. + +=head1 SOURCE + +The source code repository for Test2-Harness can be found at +F. + +=head1 MAINTAINERS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 AUTHORS + +=over 4 + +=item Chad Granum Eexodist@cpan.orgE + +=back + +=head1 COPYRIGHT + +Copyright 2020 Chad Granum Eexodist7@gmail.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut diff --git a/lib/Test2/Harness/Scheduler/Default/Run.pm b/lib/Test2/Harness/Scheduler/Default/Run.pm new file mode 100644 index 000000000..292b35e73 --- /dev/null +++ b/lib/Test2/Harness/Scheduler/Default/Run.pm @@ -0,0 +1,46 @@ +package Test2::Harness::Scheduler::Default::Run; +use strict; +use warnings; + +our $VERSION = '2.000000'; + +use parent 'Test2::Harness::Run'; + +my @NO_JSON; +BEGIN { + @NO_JSON = qw{ + todo + running + complete + }; + + sub no_json { + my $self = shift; + + return ( + $self->SUPER::no_json(), + @NO_JSON, + ); + } +} + +use Test2::Harness::Util::HashBase( + @NO_JSON, + qw{ + SUPER::init(); + + $self->{+COMPLETE} = []; + $self->{+RUNNING} = {}; + $self->{+TODO} = {}; +} + +1; diff --git a/lib/Test2/Harness/Util/IPC.pm b/lib/Test2/Harness/Util/IPC.pm deleted file mode 100644 index 88e45a35f..000000000 --- a/lib/Test2/Harness/Util/IPC.pm +++ /dev/null @@ -1,326 +0,0 @@ -package Test2::Harness::Util::IPC; -use strict; -use warnings; - -our $VERSION = '1.000152'; - -use Cwd qw/getcwd/; -use Config qw/%Config/; -use Test2::Util qw/CAN_REALLY_FORK/; - -use Importer Importer => 'import'; - -our @EXPORT_OK = qw{ - USE_P_GROUPS - run_cmd - swap_io -}; - -BEGIN { - if ($Config{'d_setpgrp'}) { - *USE_P_GROUPS = sub() { 1 }; - } - else { - *USE_P_GROUPS = sub() { 0 }; - } -} - -if (CAN_REALLY_FORK) { - *run_cmd = \&_run_cmd_fork; -} -else { - *run_cmd = \&_run_cmd_spwn; -} - -sub swap_io { - my ($fh, $to, $die, $mode) = @_; - - $die ||= sub { - my @caller = caller; - my @caller2 = caller(1); - die("$_[0] at $caller[1] line $caller[2] ($caller2[1] line $caller2[2], ${ \__FILE__ } line ${ \__LINE__ }).\n"); - }; - - my $orig_fd; - if (ref($fh) eq 'ARRAY') { - ($orig_fd, $fh) = @$fh; - } - else { - $orig_fd = fileno($fh); - } - - $die->("Could not get original fd ($fh)") unless defined $orig_fd; - - if (ref($to)) { - $mode //= $orig_fd ? '>&' : '<&'; - open($fh, $mode, $to) or $die->("Could not redirect output: $!"); - } - else { - $mode //= $orig_fd ? '>' : '<'; - open($fh, $mode, $to) or $die->("Could not redirect output to '$to': $!"); - } - - return if fileno($fh) == $orig_fd; - - $die->("New handle does not have the desired fd!"); -} - -sub _run_cmd_fork { - my %params = @_; - - my $cmd = $params{command} or die "No 'command' specified"; - - my $pid = fork; - die "Failed to fork" unless defined $pid; - if ($pid) { - $_->() for @{$params{run_in_parent} // []}; - return $pid; - } - else { - $_->() for @{$params{run_in_child} // []}; - } - %ENV = (%ENV, %{$params{env}}) if $params{env}; - setpgrp(0, 0) if USE_P_GROUPS && !$params{no_set_pgrp}; - - $cmd = [$cmd->()] if ref($cmd) eq 'CODE'; - - if (my $dir = $params{chdir} // $params{ch_dir}) { - chdir($dir) or die "Could not chdir: $!"; - } - - my $stdout = $params{stdout}; - my $stderr = $params{stderr}; - my $stdin = $params{stdin}; - - open(my $OLD_STDERR, '>&', \*STDERR) or die "Could not clone STDERR: $!"; - - my $die = sub { - my $caller1 = $params{caller1}; - my $caller2 = $params{caller2}; - my $msg = "$_[0] at $caller1->[1] line $caller1->[2] ($caller2->[1] line $caller2->[2]).\n"; - print $OLD_STDERR $msg; - print STDERR $msg; - POSIX::_exit(127); - }; - - swap_io(\*STDERR, $stderr, $die) if $stderr; - swap_io(\*STDOUT, $stdout, $die) if $stdout; - swap_io(\*STDIN, $stdin, $die) if $stdin; - open(STDIN, "<", "/dev/null") if !$stdin; - - @$cmd = map { ref($_) eq 'CODE' ? $_->() : $_ } @$cmd; - - exec(@$cmd) or $die->("Failed to exec!"); -} - -sub _run_cmd_spwn { - my %params = @_; - - local %ENV = (%ENV, %{$params{env}}) if $params{env}; - - my $cmd = $params{command} or die "No 'command' specified"; - $cmd = [$cmd->()] if ref($cmd) eq 'CODE'; - - my $cwd; - if (my $dir = $params{chdir} // $params{ch_dir}) { - $cwd = getcwd(); - chdir($dir) or die "Could not chdir: $!"; - } - - my $stdout = $params{stdout}; - my $stderr = $params{stderr}; - my $stdin = $params{stdin}; - - open(my $OLD_STDIN, '<&', \*STDIN) or die "Could not clone STDIN: $!"; - open(my $OLD_STDOUT, '>&', \*STDOUT) or die "Could not clone STDOUT: $!"; - open(my $OLD_STDERR, '>&', \*STDERR) or die "Could not clone STDERR: $!"; - - my $die = sub { - my $caller1 = $params{caller1}; - my $caller2 = $params{caller2}; - my $msg = "$_[0] at $caller1->[1] line $caller1->[2] ($caller2->[1] line $caller2->[2], ${ \__FILE__ } line ${ \__LINE__ }).\n"; - print $OLD_STDERR $msg; - print STDERR $msg; - POSIX::_exit(127); - }; - - swap_io(\*STDIN, $stdin, $die) if $stdin; - swap_io(\*STDOUT, $stdout, $die) if $stdout; - $stdin ? swap_io(\*STDIN, $stdin, $die) : close(STDIN); - - local $?; - my $pid; - my $ok = eval { $pid = system 1, map { ref($_) eq 'CODE' ? $_->() : $_ } @$cmd }; - my $bad = $?; - my $err = $@; - - swap_io($stdin ? \*STDIN : [0, \*STDIN], $OLD_STDIN, $die); - swap_io(\*STDERR, $OLD_STDERR, $die) if $stderr; - swap_io(\*STDOUT, $OLD_STDOUT, $die) if $stdout; - - if ($cwd) { - chdir($cwd) or die "Could not chdir: $!"; - } - - die $err unless $ok; - die "Spawn resulted in code $bad" if $bad && $bad != $pid; - die "Failed to spawn" unless $pid; - - $_->() for @{$params{run_in_parent} // []}; - - return $pid; -} - -1; - -__END__ - -=pod - -=encoding UTF-8 - -=head1 NAME - -Test2::Harness::Util::IPC - Utilities for IPC management. - -=head1 DESCRIPTION - -This package provides low-level IPC tools for Test2::Harness. - -=head1 EXPORTS - -All exports are optional and must be specified at import time. - -=over 4 - -=item $bool = USE_P_GROUPS() - -This is a shortcut for: - - use Config qw/%Config/; - $Config{'d_setpgrp'}; - -=item swap_io($from, $to) - -=item swap_io($from, $to, \&die) - -This will close and re-open the file handle designated by C<$from> so that it -redirects to the handle specified in C<$to>. It preserves the file descriptor -in the process, and throws an exception if it fails to do so. - - swap_io(\*STDOUT, $fh); - # STDOUT now points to wherever $fh did, but maintains the file descriptor number '2'. - -As long as the file descriptor is greater than 0 it will open for writing. If -the descriptor is 0 it will open for reading, allowing for a swap of C -as well. - -Extra effort is made to insure errors go to the real C, specially when -trying to swap out C. If you have trouble with this, or do not trust -it, you can provide a custom coderef as a third argument, this coderef will be -used instead of C to throw exceptions. - -Note that the custom die logic when you do not provide your own bypasses the -exception catching mechanism and will exit your program. If this is not -desirable then you should provide a custom die subref. - -=item $pid = run_cmd(command => [...], %params) - -This function will run the specified command and return a pid to you. When -possible this will be done via C and C. When that is not -possible it uses the C trick to spawn a new process. Some -parameters do not work in the second case, and are silently ignored. - -Parameters: - -=over 4 - -=item command => [$command, sub { ... }, @args] - -=item command => sub { return ($command, @args) } - -This parameter is required. This should either be an arrayref of arguments for -C, or a coderef that returns a list of arguments for C. On -systems without fork/exec the arguments will be passed to -C instead. - -If the command arrayref has a coderef in it, the coderef will be run and its -return value(s) will be inserted in its place. This replacement happens -post-chroot - -=item run_in_parent => [sub { ... }, sub { ... }] - -An arrayref of callbacks to be run in the parent process immedietly after the -child process is started. - -=item run_in_child => [sub { ... }, sub { ... }] - -An arrayref of callbacks to be run in the child process immedietly after fork. -This parameter is silently ignored on systems without fork/exec. - -=item env => { ENVVAR => $VAL, ... } - -A hashref of custom environment variables to set in the child process. In the -fork/exec model this is done post-fork, in the spawn model this is done via -local prior to the spawn. - -=item no_set_pgrp => $bool, - -Normall C is called on systems where it is supported. You can use -this parameter to override the normal behavior. setpgrp() is not called in the -spawn model, so this parameter is silently ignored there. - -=item chdir => 'path/to/dir' - -=item ch_dir => 'path/to/dir' - -chdir() to the specified directory for the new process. In the fork/exec model -this is done post-fork in the child. In the spawn model this is done before the -spawn, then a second chdir() puts the parent process back to its original dir -after the spawn. - -=item stdout => $handle - -=item stderr => $handle - -=item stdin => $handle - -Thise can be used to provide custom STDERR, STDOUT, and STDIN. In the fork/exec -model these are swapped into place post-fork in the child. In the spawn model -the swap occurs pre-spawn, then the old handles are swapped back post-spawn. - -=back - -=back - -=head1 SOURCE - -The source code repository for Test2-Harness can be found at -F. - -=head1 MAINTAINERS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 AUTHORS - -=over 4 - -=item Chad Granum Eexodist@cpan.orgE - -=back - -=head1 COPYRIGHT - -Copyright 2020 Chad Granum Eexodist7@gmail.comE. - -This program is free software; you can redistribute it and/or -modify it under the same terms as Perl itself. - -See F - -=cut