File Coverage

blib/lib/Test2/API/InterceptResult.pm

Criterion	Covered	Total	%
statement	109	111	98.2
branch	17	20	85.0
condition	13	19	68.4
subroutine	34	36	94.4
pod	23	23	100.0
total	196	209	93.7

package Test2::API::InterceptResult;
use strict;
use warnings;

our $VERSION = '1.302180';

use Scalar::Util qw/blessed/;
use Test2::Util  qw/pkg_to_file/;
use Storable     qw/dclone/;
use Carp         qw/croak/;

use Test2::API::InterceptResult::Squasher;
use Test2::API::InterceptResult::Event;
use Test2::API::InterceptResult::Hub;

sub new {
    croak "Called a method that creates a new instance in void context" unless defined wantarray;
    my $class = shift;
    bless([@_], $class);
}

sub new_from_ref {
    croak "Called a method that creates a new instance in void context" unless defined wantarray;
    bless($_[1], $_[0]);
}

sub clone { blessed($_[0])->new(@{dclone($_[0])}) }

sub event_list { @{$_[0]} }

sub _upgrade {
    my $self = shift;
    my ($event, %params) = @_;

    my $blessed = blessed($event);

    my $upgrade_class = $params{upgrade_class} ||= 'Test2::API::InterceptResult::Event';

    return $event if $blessed && $event->isa($upgrade_class) && !$params{_upgrade_clone};

    my $fd = dclone($blessed ? $event->facet_data : $event);

    my $class = $params{result_class} ||= blessed($self);

    if (my $parent = $fd->{parent}) {
        $parent->{children} = $class->new_from_ref($parent->{children} || [])->upgrade(%params);
    }

    my $uc_file = pkg_to_file($upgrade_class);
    require($uc_file) unless $INC{$uc_file};
    return $upgrade_class->new(facet_data => $fd, result_class => $class);
}

sub hub {
    my $self = shift;

    my $hub = Test2::API::InterceptResult::Hub->new();
    $hub->process($_) for @$self;
    $hub->set_ended(1);

    return $hub;
}

sub state {
    my $self = shift;
    my %params = @_;

    my $hub = $self->hub;

    my $out = {
        map {($_ => scalar $hub->$_)} qw/count failed is_passing plan bailed_out skip_reason/
    };

    $out->{bailed_out} = $self->_upgrade($out->{bailed_out}, %params)->bailout_reason || 1
        if $out->{bailed_out};

    $out->{follows_plan} = $hub->check_plan;

    return $out;
}

sub upgrade {
    my $self = shift;
    my %params = @_;

    my @out = map { $self->_upgrade($_, %params, _upgrade_clone => 1) } @$self;

    return blessed($self)->new_from_ref(\@out)
        unless $params{in_place};

    @$self = @out;
    return $self;
}

sub squash_info {
    my $self = shift;
    my %params = @_;

    my @out;

    {
        my $squasher = Test2::API::InterceptResult::Squasher->new(events => \@out);
        # Clone to make sure we do not indirectly modify an existing one if it
        # is already upgraded
        $squasher->process($self->_upgrade($_, %params)->clone) for @$self;
        $squasher->flush_down();
    }

    return blessed($self)->new_from_ref(\@out)
        unless $params{in_place};

    @$self = @out;
    return $self;
}

sub asserts        { shift->grep(has_assert     => @_) }
sub subtests       { shift->grep(has_subtest    => @_) }
sub diags          { shift->grep(has_diags      => @_) }
sub notes          { shift->grep(has_notes      => @_) }
sub errors         { shift->grep(has_errors     => @_) }
sub plans          { shift->grep(has_plan       => @_) }
sub causes_fail    { shift->grep(causes_fail    => @_) }
sub causes_failure { shift->grep(causes_failure => @_) }

sub flatten         { shift->map(flatten        => @_) }
sub briefs          { shift->map(brief          => @_) }
sub summaries       { shift->map(summary        => @_) }
sub subtest_results { shift->map(subtest_result => @_) }
sub diag_messages   { shift->map(diag_messages  => @_) }
sub note_messages   { shift->map(note_messages  => @_) }
sub error_messages  { shift->map(error_messages => @_) }

no warnings 'once';

*map = sub {
    my $self = shift;
    my ($call, %params) = @_;

    my $args = $params{args} ||= [];

    return [map { local $_ = $self->_upgrade($_, %params); $_->$call(@$args) } @$self];
};

*grep = sub {
    my $self = shift;
    my ($call, %params) = @_;

    my $args = $params{args} ||= [];

    my @out = grep { local $_ = $self->_upgrade($_, %params); $_->$call(@$args) } @$self;

    return blessed($self)->new_from_ref(\@out)
        unless $params{in_place};

    @$self = @out;
    return $self;
};

1;

__END__