1package Test2::API::InterceptResult::Squasher; 2use strict; 3use warnings; 4 5our $VERSION = '1.302194'; 6 7use Carp qw/croak/; 8use List::Util qw/first/; 9 10use Test2::Util::HashBase qw{ 11 <events 12 13 +down_sig +down_buffer 14 15 +up_into +up_sig +up_clear 16}; 17 18sub init { 19 my $self = shift; 20 21 croak "'events' is a required attribute" unless $self->{+EVENTS}; 22} 23 24sub can_squash { 25 my $self = shift; 26 my ($event) = @_; 27 28 # No info, no squash 29 return unless $event->has_info; 30 31 # Do not merge up if one of these is true 32 return if first { $event->$_ } 'causes_fail', 'has_assert', 'has_bailout', 'has_errors', 'has_plan', 'has_subtest'; 33 34 # Signature if we can squash 35 return $event->trace_signature; 36} 37 38sub process { 39 my $self = shift; 40 my ($event) = @_; 41 42 return if $self->squash_up($event); 43 return if $self->squash_down($event); 44 45 $self->flush_down($event); 46 47 push @{$self->{+EVENTS}} => $event; 48 49 return; 50} 51 52sub squash_down { 53 my $self = shift; 54 my ($event) = @_; 55 56 my $sig = $self->can_squash($event) 57 or return; 58 59 $self->flush_down() 60 if $self->{+DOWN_SIG} && $self->{+DOWN_SIG} ne $sig; 61 62 $self->{+DOWN_SIG} ||= $sig; 63 push @{$self->{+DOWN_BUFFER}} => $event; 64 65 return 1; 66} 67 68sub flush_down { 69 my $self = shift; 70 my ($into) = @_; 71 72 my $sig = delete $self->{+DOWN_SIG}; 73 my $buffer = delete $self->{+DOWN_BUFFER}; 74 75 return unless $buffer && @$buffer; 76 77 my $fsig = $into ? $into->trace_signature : undef; 78 79 if ($fsig && $fsig eq $sig) { 80 $self->squash($into, @$buffer); 81 } 82 else { 83 push @{$self->{+EVENTS}} => @$buffer if $buffer; 84 } 85} 86 87sub clear_up { 88 my $self = shift; 89 90 return unless $self->{+UP_CLEAR}; 91 92 delete $self->{+UP_INTO}; 93 delete $self->{+UP_SIG}; 94 delete $self->{+UP_CLEAR}; 95} 96 97sub squash_up { 98 my $self = shift; 99 my ($event) = @_; 100 no warnings 'uninitialized'; 101 102 $self->clear_up; 103 104 if ($event->has_assert) { 105 if(my $sig = $event->trace_signature) { 106 $self->{+UP_INTO} = $event; 107 $self->{+UP_SIG} = $sig; 108 $self->{+UP_CLEAR} = 0; 109 } 110 else { 111 $self->{+UP_CLEAR} = 1; 112 $self->clear_up; 113 } 114 115 return; 116 } 117 118 my $into = $self->{+UP_INTO} or return; 119 120 # Next iteration should clear unless something below changes that 121 $self->{+UP_CLEAR} = 1; 122 123 # Only merge into matching trace signatres 124 my $sig = $self->can_squash($event); 125 return unless $sig eq $self->{+UP_SIG}; 126 127 # OK Merge! Do not clear merge in case the return event is also a matching sig diag-only 128 $self->{+UP_CLEAR} = 0; 129 130 $self->squash($into, $event); 131 132 return 1; 133} 134 135sub squash { 136 my $self = shift; 137 my ($into, @from) = @_; 138 push @{$into->facet_data->{info}} => $_->info for @from; 139} 140 141sub DESTROY { 142 my $self = shift; 143 144 return unless $self->{+EVENTS}; 145 $self->flush_down(); 146 return; 147} 148 1491; 150 151__END__ 152 153=pod 154 155=encoding UTF-8 156 157=head1 NAME 158 159Test2::API::InterceptResult::Squasher - Encapsulation of the algorithm that 160squashes diags into assertions. 161 162=head1 DESCRIPTION 163 164Internal use only, please ignore. 165 166=head1 SOURCE 167 168The source code repository for Test2 can be found at 169F<http://github.com/Test-More/test-more/>. 170 171=head1 MAINTAINERS 172 173=over 4 174 175=item Chad Granum E<lt>exodist@cpan.orgE<gt> 176 177=back 178 179=head1 AUTHORS 180 181=over 4 182 183=item Chad Granum E<lt>exodist@cpan.orgE<gt> 184 185=back 186 187=head1 COPYRIGHT 188 189Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. 190 191This program is free software; you can redistribute it and/or 192modify it under the same terms as Perl itself. 193 194See F<http://dev.perl.org/licenses/> 195 196=cut 197