File Coverage

blib/lib/Data/Focus/LensTester.pm

Criterion	Covered	Total	%
statement	86	86	100.0
branch	11	16	68.7
condition	1	3	33.3
subroutine	20	20	100.0
pod	3	3	100.0
total	121	128	94.5

package Data::Focus::LensTester;
use strict;
use warnings;
use Carp;
use Test::More;
use Data::Focus qw(focus);
use Scalar::Util qw(refaddr);

sub new {
    my ($class, %args) = @_;
    my $self = bless {
        map { ($_ => $args{$_}) } qw(test_whole test_part parts)
    }, $class;
    foreach my $key (qw(test_whole test_part)) {
        croak "$key must be a code-ref" if ref($self->{$key}) ne "CODE";
    }
    croak "parts must be an array-ref" if ref($self->{parts}) ne "ARRAY";
    return $self;
}

sub parts {
    return @{$_[0]->{parts}};
}

sub test_lens_laws {
    my ($self, %args) = @_;
    my @args = _get_args(%args);
    my $exp_focal_points = $args[2];
    $self->_test_focal_points(@args);
    $self->_test_set_set(@args);
    if($exp_focal_points == 0) {
        $self->_test_get_set(@args);
    }elsif($exp_focal_points == 1) {
        $self->_test_get_set(@args);
        $self->_test_set_get(@args);
    }else {
        $self->_test_set_get(@args);
    }
}

sub _get_args {
    my (%args) = @_;
    my $lens = $args{lens};
    croak "lens must be Data::Focus::Lens object" if !eval { $lens->isa("Data::Focus::Lens") };
    my $target = $args{target};
    croak "target must be a code-ref" if ref($target) ne "CODE";
    my $exp_focal_points = $args{exp_focal_points};
    croak "exp_focal_points must be Int" if !defined($exp_focal_points) || $exp_focal_points !~ /^\d+$/;
    return ($target, $lens, $exp_focal_points);
}

sub _test_focal_points {
    my ($self, $target, $lens, $exp_focal_points) = @_;
    subtest "focal points" => sub {
        my @ret = focus($target->())->list($lens);
        is scalar(@ret), $exp_focal_points, "list() returns $exp_focal_points focal points";
    };
}

sub _test_set_set {
    my ($self, $target, $lens, $exp_focal_points) = @_;
    subtest "set-set law" => sub {
        foreach my $i1 (0 .. $#{$self->{parts}}) {
            foreach my $i2 (0 .. $#{$self->{parts}}) {
                next if $i1 == $i2;
                my ($part1, $part2) = @{$self->{parts}}[$i1, $i2];
                my $left_target = $target->();
                my $right_target = $target->();
                my $left_result = focus( focus($left_target)->set($lens, $part1) )->set($lens, $part2);
                my $right_result = focus($right_target)->set($lens, $part2);
                $self->{test_whole}->($left_result, $right_result);
            }
        }
    };
}

sub _test_set_get {
    my ($self, $target, $lens, $exp_focal_points) = @_;
    subtest "set-get law" => sub {
        foreach my $part (@{$self->{parts}}) {
            my $left_target = $target->();
            my $left_set = focus($left_target)->set($lens, $part);
            my @left_parts = focus($left_set)->list($lens);
            $self->{test_part}->($_, $part) foreach @left_parts;
        }
    };
}

sub _test_get_set {
    my ($self, $target, $lens, $exp_focal_points) = @_;
    subtest "get-set law" => sub {
        foreach my $part (@{$self->{parts}}) {
            my $left_target = $target->();
            my $left_result = focus($left_target)->set($lens, focus($left_target)->get($lens));
            $self->{test_whole}->($left_result, $target->());
        }
    };
}

foreach my $method_base (qw(set_set set_get get_set)) {
    no strict "refs";
    my $method_impl = "_test_$method_base";
    *{"test_$method_base"} = sub {
        my ($self, %args) = @_;
        my @args = _get_args(%args);
        $self->_test_focal_points(@args);
        $self->$method_impl(@args);
    };
}

1;
__END__