package Test2::Harness::Watcher; use strict; use warnings; our $VERSION = '0.001063'; use Carp qw/croak/; 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/; use Test2::Harness::Util::HashBase qw{ -job -live -_complete -killed -events -assertion_count -exit -plan -_errors -_failures -_sub_failures -_plans -_info -_sub_info -nested -subtests -numbers -last_event }; sub init { my $self = shift; croak "'job' is a required attribute" unless $self->{+JOB}; $self->{+_FAILURES} = 0; $self->{+_ERRORS} = 0; $self->{+ASSERTION_COUNT} = 0; $self->{+NUMBERS} = {}; $self->{+NESTED} = 0 unless defined $self->{+NESTED}; } sub clear_events { delete $_[0]->{+EVENTS} } sub has_exit { defined $_[0]->{+EXIT} } sub has_plan { defined $_[0]->{+PLAN} } sub file { my $self = shift; return $self->{+JOB}->file; } sub process { my $self = shift; my ($event) = @_; my @e = $self->_process($event); push @{$self->{+EVENTS}} => ($event, @e); return @e; } sub _process { my $self = shift; my ($event) = @_; $self->{+LAST_EVENT} = time; my $f = $event->{facet_data}; my $hf = hub_truth($f); return if $hf->{buffered}; my $nested = $hf->{nested} || 0; 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 send 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(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); $self->{+NUMBERS}->{$f->{assert}->{number}}++ if $f->{assert} && $f->{assert}->{number}; if ($f->{parent} && $f->{assert}) { my $subwatcher = blessed($self)->new(nested => $self->{+NESTED} + 1, job => $self->{+JOB}); 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}; } if (@errors) { $self->{+_SUB_FAILURES}++; push @{$f->{errors}} => @errors; } else { my $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}}; $self->{+_SUB_FAILURES}++ if $fail; } } $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; } if ($f->{plan} && !$f->{plan}->{none}) { $self->{+_PLANS}++; $self->{+PLAN} = $f->{plan}; } if ($f->{harness_job_exit} && defined $f->{harness_job_exit}->{exit}) { $self->{+EXIT} = $f->{harness_job_exit}->{exit}; } return; } sub fail { my $self = shift; return !!$self->fail_error_facet_list; } 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)"} } elsif (my $exit = ($wstat >> 8)) { push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Test script returned error (Code: $exit)"} } elsif (my $sig = $wstat & 127) { push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Test script returned error (Signal: $sig)"} } else { push @out => {tag => 'REASON', fail => 1, from_harness => 1, details => "Test script returned error (wstat: $wstat)"} } } 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 => {tag => 'REASON', fail => 1, from_harness => 1, details => "Test file was killed"} if $self->{+KILLED}; push @out => $self->subtest_fail_error_facet_list(); return @out; } sub pass { my $self = shift; return !$self->fail; } # We do not ever want the watcher to be stored sub TO_JSON { undef } sub kill { my $self = shift; $self->{+KILLED} = time; return 0 unless $self->{+LIVE}; return 1 if defined $self->{+EXIT}; my $pid = $self->{+JOB}->pid; return kill('TERM', $pid) if $pid; return 0; } sub set_complete { my $self = shift; ($self->{+_COMPLETE}) = @_; } sub complete { my $self = shift; return 1 unless $self->{+LIVE}; return 1 if $self->{+_COMPLETE}; my $exit = $self->{+EXIT}; my $plan = $self->{+PLAN} ? $self->{+PLAN}->{count} : undef; my $count = $self->{+ASSERTION_COUNT}; my $has_exit = defined($exit) ? 1 : 0; my $has_plan = defined($plan) ? 1 : 0; return $self->{+_COMPLETE} = 1 if $self->{+KILLED} && $has_exit; # Script exited badly return $self->{+_COMPLETE} = 1 if $exit; # Script exited with no plan or assertions return $self->{+_COMPLETE} = 1 if $has_exit && !$has_plan && !$count; # Script exited with completed plan return $self->{+_COMPLETE} = 1 if $has_exit && $has_plan && $plan <= $count; return 0; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Harness::Watcher - Class to monitor events for a single job and pass judgement on the result. =head1 DESCRIPTION =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 2017 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