Server IP : 85.214.239.14 / Your IP : 18.221.80.42 Web Server : Apache/2.4.62 (Debian) System : Linux h2886529.stratoserver.net 4.9.0 #1 SMP Tue Jan 9 19:45:01 MSK 2024 x86_64 User : www-data ( 33) PHP Version : 7.4.18 Disable Function : pcntl_alarm,pcntl_fork,pcntl_waitpid,pcntl_wait,pcntl_wifexited,pcntl_wifstopped,pcntl_wifsignaled,pcntl_wifcontinued,pcntl_wexitstatus,pcntl_wtermsig,pcntl_wstopsig,pcntl_signal,pcntl_signal_get_handler,pcntl_signal_dispatch,pcntl_get_last_error,pcntl_strerror,pcntl_sigprocmask,pcntl_sigwaitinfo,pcntl_sigtimedwait,pcntl_exec,pcntl_getpriority,pcntl_setpriority,pcntl_async_signals,pcntl_unshare, MySQL : OFF | cURL : OFF | WGET : ON | Perl : ON | Python : ON | Sudo : ON | Pkexec : OFF Directory : /usr/share/perl/5.36/Test2/API/InterceptResult/ |
Upload File : |
package Test2::API::InterceptResult::Squasher; use strict; use warnings; our $VERSION = '1.302190'; use Carp qw/croak/; use List::Util qw/first/; use Test2::Util::HashBase qw{ <events +down_sig +down_buffer +up_into +up_sig +up_clear }; sub init { my $self = shift; croak "'events' is a required attribute" unless $self->{+EVENTS}; } sub can_squash { my $self = shift; my ($event) = @_; # No info, no squash return unless $event->has_info; # Do not merge up if one of these is true return if first { $event->$_ } 'causes_fail', 'has_assert', 'has_bailout', 'has_errors', 'has_plan', 'has_subtest'; # Signature if we can squash return $event->trace_signature; } sub process { my $self = shift; my ($event) = @_; return if $self->squash_up($event); return if $self->squash_down($event); $self->flush_down($event); push @{$self->{+EVENTS}} => $event; return; } sub squash_down { my $self = shift; my ($event) = @_; my $sig = $self->can_squash($event) or return; $self->flush_down() if $self->{+DOWN_SIG} && $self->{+DOWN_SIG} ne $sig; $self->{+DOWN_SIG} ||= $sig; push @{$self->{+DOWN_BUFFER}} => $event; return 1; } sub flush_down { my $self = shift; my ($into) = @_; my $sig = delete $self->{+DOWN_SIG}; my $buffer = delete $self->{+DOWN_BUFFER}; return unless $buffer && @$buffer; my $fsig = $into ? $into->trace_signature : undef; if ($fsig && $fsig eq $sig) { $self->squash($into, @$buffer); } else { push @{$self->{+EVENTS}} => @$buffer if $buffer; } } sub clear_up { my $self = shift; return unless $self->{+UP_CLEAR}; delete $self->{+UP_INTO}; delete $self->{+UP_SIG}; delete $self->{+UP_CLEAR}; } sub squash_up { my $self = shift; my ($event) = @_; no warnings 'uninitialized'; $self->clear_up; if ($event->has_assert) { if(my $sig = $event->trace_signature) { $self->{+UP_INTO} = $event; $self->{+UP_SIG} = $sig; $self->{+UP_CLEAR} = 0; } else { $self->{+UP_CLEAR} = 1; $self->clear_up; } return; } my $into = $self->{+UP_INTO} or return; # Next iteration should clear unless something below changes that $self->{+UP_CLEAR} = 1; # Only merge into matching trace signatres my $sig = $self->can_squash($event); return unless $sig eq $self->{+UP_SIG}; # OK Merge! Do not clear merge in case the return event is also a matching sig diag-only $self->{+UP_CLEAR} = 0; $self->squash($into, $event); return 1; } sub squash { my $self = shift; my ($into, @from) = @_; push @{$into->facet_data->{info}} => $_->info for @from; } sub DESTROY { my $self = shift; return unless $self->{+EVENTS}; $self->flush_down(); return; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::API::InterceptResult::Squasher - Encapsulation of the algorithm that squashes diags into assertions. =head1 DESCRIPTION Internal use only, please ignore. =head1 SOURCE The source code repository for Test2 can be found at F<http://github.com/Test-More/test-more/>. =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>exodist@cpan.orgE<gt>. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F<http://dev.perl.org/licenses/> =cut