Dave Cross: Still Munging Data With Perl: Online event - Mar 17 Learn more

use strict;
our $VERSION = '1.000103';
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/;
-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<Test2::Harness::Auditor::TimeTracker> 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
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist7@gmail.comE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut