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