File Coverage

blib/lib/Test/Approximate.pm

Criterion	Covered	Total	%
statement	69	73	94.5
branch	19	26	73.0
condition	8	15	53.3
subroutine	14	14	100.0
pod	2	3	66.6
total	112	131	85.5

package Test::Approximate;
# ABSTRACT: Test and deeply test two number is approximate equality
use strict;
use warnings;

our $VERSION = 0.009;

use POSIX qw( strtod );
use Test::Builder;
our $Test = Test::Builder->new;

use base 'Exporter';
our @EXPORT = qw( is_approx approx );

our $DEFAULT_TOLERANCE = '1%';

sub is_approx {
    my ( $got, $expected, $msg, $tolerance ) = @_;

    $tolerance //= $DEFAULT_TOLERANCE;

    # build some diagnostics info
    my $short1 = length($got) > 12 ? substr($got, 0, 8) . '...' : $got;
    my $short2 = length($expected) > 12 ? substr($expected, 0, 8) . '...' : $expected;
    my $msg2 = "'$short1' =~ '$short2'";

    #set default message
    $msg = $msg2 unless defined($msg);

    unless ( $Test->ok(_is_approx($got, $expected, $tolerance), $msg) ) {
        $Test->diag("  test: $msg");

        if ( check_type($got) eq 'str' or check_type($expected) eq 'str' ) {
            $Test->diag(" error: diff between string\n     got: $got\nexpected: $expected");
            return;
        }
        my $diff = $got - $expected;
        if ( $tolerance =~ /^(.+)%$/ ) {
            my $percentage = ( $diff / $expected ) * 100;
            $Test->diag("  error: diff $percentage% is not under tolerance $tolerance");
        }
        else {
            $Test->diag("  error: diff $diff is not under tolerance $tolerance");
        }
    }

}

sub _is_approx {
    my ( $num1, $num2, $tolerance ) = @_;

    # borrowed form Test::Approx
    my $num1_type = check_type($num1);
    my $num2_type = check_type($num2);

    if ( $num1_type eq 'str' or $num2_type eq 'str' ) {
        return $num1 eq $num2;
    }
    # figure out what to use as the threshold
    my $threshold;
    if ( $tolerance =~ /^(.+)%$/ ) {
        my $percent = $1 / 100;

        $threshold = strtod( abs( $num1 * $percent ) );
    } else {
        $threshold = $tolerance;
    }

    my $dist = strtod( abs($num2 - $num1) );
    return $dist <= $threshold ? 1 : 0;
}

# borrowed from Test::Approx
sub check_type {
    my $arg = shift;

    local $! = 0;
    my ( $num, $unparsed ) = strtod($arg);
    return 'str' if ( ($arg eq '') || ($unparsed != 0) || $! );
    return 'num';
}

# deeply test approx
sub approx {
    my ( $structure, $torlerance ) = @_;

    if ( ref $structure eq '' ) {        # value
        return Test::Deep::Approximate->new($structure, $torlerance);
    }
    elsif ( ref $structure eq ref {} ) { # hash

        my $hash = {};
        foreach my $key ( keys %$structure ) {
            $hash->{$key} = approx($structure->{$key}, $torlerance);
        }
        return $hash;
    }
    elsif ( ref $structure eq ref [] ) { # array

        my $array = [];
        for my $item ( @$structure ) {
            push @$array, approx($item, $torlerance);
        }
        return $array;
    }
}

{
    package Test::Deep::Approximate;
    use Test::Deep::Cmp;

    sub init {
        my ( $self, $expect, $torlerance ) = @_;

        $self->{expect} = $expect;
        $self->{torlerance} = $torlerance;
    }

    sub _is_approx {
        shift;
        return  Test::Approximate::_is_approx(@_);
    }

    sub descend {
        my ( $self, $got ) = @_;

        return $self->_is_approx($got, $self->{expect}, $self->{torlerance});
    }

    sub diagnostics {
        my ( $self, $where, $last ) = @_;

        my $got = $last->{got};
        my $diag = <
Comparing $where
     got : $got
expected : $self->{expect}
EOM
        return $diag;
    }

}

1;

__END__