File Coverage

blib/lib/Test2/Tools/Tester.pm

Criterion	Covered	Total	%
statement	74	76	97.3
branch	22	24	91.6
condition	2	6	33.3
subroutine	10	10	100.0
pod	1	3	33.3
total	109	119	91.6

package Test2::Tools::Tester;
use strict;
use warnings;

our $VERSION = '0.000153';

use Carp qw/croak/;
use Test2::Util::Ref qw/rtype/;

BEGIN {
    if (eval { require Module::Pluggable; 1 }) {
        Module::Pluggable->import(search_path => ['Test2::EventFacet'], require => 1);
    }
    else {
        require Test2::EventFacet::About;
        require Test2::EventFacet::Amnesty;
        require Test2::EventFacet::Assert;
        require Test2::EventFacet::Control;
        require Test2::EventFacet::Error;
        require Test2::EventFacet::Hub;
        require Test2::EventFacet::Info;
        require Test2::EventFacet::Info::Table;
        require Test2::EventFacet::Meta;
        require Test2::EventFacet::Parent;
        require Test2::EventFacet::Plan;
        require Test2::EventFacet::Render;
        require Test2::EventFacet::Trace;

        *plugins = sub {
            return (
                'Test2::EventFacet::About',
                'Test2::EventFacet::Amnesty',
                'Test2::EventFacet::Assert',
                'Test2::EventFacet::Control',
                'Test2::EventFacet::Error',
                'Test2::EventFacet::Hub',
                'Test2::EventFacet::Info',
                'Test2::EventFacet::Info::Table',
                'Test2::EventFacet::Meta',
                'Test2::EventFacet::Parent',
                'Test2::EventFacet::Plan',
                'Test2::EventFacet::Render',
                'Test2::EventFacet::Trace',
            );
        };
    }
}

use Test2::Util::Importer 'Test2::Util::Importer' => 'import';

our @EXPORT_OK = qw{
    facets
    filter_events
    event_groups
};

my %TYPES;
for my $class (__PACKAGE__->plugins) {
    my $type = $class;
    $type =~ s/^Test2::EventFacet:://g;

    next unless $class->isa('Test2::EventFacet');
    my $key;
    $key = $class->facet_key if $class->can('facet_key');
    $key = lc($type) unless defined $key;

    $TYPES{$type}     = $class;
    $TYPES{lc($type)} = $class;
    $TYPES{$key}      = $class;
}

sub filter_events {
    my $events = shift;

    my @match = map { rtype($_) eq 'REGEXP' ? $_ : qr/^\Q$_\E::/} @_;

    my @out;
    for my $e (@$events) {
        my $trace = $e->facet_data->{trace} or next;
        next unless grep { $trace->{frame}->[3] =~ $_ } @match;
        push @out => $e;
    }

    return \@out;
}

sub event_groups {
    my $events = shift;

    my $out = {};
    for my $e (@$events) {
        my $trace = $e->facet_data->{trace};
        my $tool = ($trace && $trace->{frame} && $trace->{frame}->[3]) ? $trace->{frame}->[3] : undef;

        unless ($tool) {
            push @{$out->{__NA__}} => $e;
            next;
        }

        my ($pkg, $sub) = ($tool =~ m/^(.*)(?:::|')([^:']+)$/);

        push @{$out->{$pkg}->{$sub}} => $e;
        push @{$out->{$pkg}->{__ALL__}} => $e;
    }

    return $out;
}

sub facets {
    my ($type, $events) = @_;

    my ($key, $is_list);
    my $class = $TYPES{$type};
    if ($class) {
        $key = $class->facet_key || lc($type);
        $is_list = $class->is_list;
    }
    else {
        $key = lc($type);
    }

    my @out;
    for my $e (@$events) {
        my $fd = $e->facet_data;
        my $f  = $fd->{$key} or next;

        my $list = defined($is_list) ? $is_list : rtype($f) eq 'ARRAY';

        if ($list) {
            push @out => map { $class ? $class->new($_) : $_ } @$f;
        }
        else {
            push @out => $class ? $class->new($f) : $f;
        }
    }

    return \@out;
}

1;

__END__