File Coverage

blib/lib/Test/Number/Delta.pm

Criterion	Covered	Total	%
statement	80	80	100.0
branch	38	38	100.0
condition	6	9	66.6
subroutine	13	13	100.0
pod	4	4	100.0
total	141	144	97.9

use strict;
use warnings;

package Test::Number::Delta;
# ABSTRACT: Compare the difference between numbers against a given tolerance
our $VERSION = '1.04'; # VERSION

use vars qw (@EXPORT @ISA);

# Required modules
use Carp;
use Test::Builder;
use Exporter;

@ISA    = qw( Exporter );
@EXPORT = qw( delta_not_ok delta_ok delta_within delta_not_within );


my $Test     = Test::Builder->new;
my $Epsilon  = 1e-6;
my $Relative = undef;

sub import {
    my $self  = shift;
    my $pack  = caller;
    my $found = grep /within|relative/, @_;
    croak "Can't specify more than one of 'within' or 'relative'"
      if $found > 1;
    if ($found) {
        my ( $param, $value ) = splice @_, 0, 2;
        croak "'$param' parameter must be non-zero"
          if $value == 0;
        if ( $param eq 'within' ) {
            $Epsilon = abs($value);
        }
        elsif ( $param eq 'relative' ) {
            $Relative = abs($value);
        }
        else {
            croak "Test::Number::Delta parameters must come first";
        }
    }
    $Test->exported_to($pack);
    $Test->plan(@_);
    $self->export_to_level( 1, $self, $_ ) for @EXPORT;
}

#--------------------------------------------------------------------------#
# _check -- recursive function to perform comparison
#--------------------------------------------------------------------------#

sub _check {
    my ( $p, $q, $epsilon, $name, @indices ) = @_;
    my ( $ok, $diag ) = ( 1, q{} ); # assume true
    if ( ref $p eq 'ARRAY' || ref $q eq 'ARRAY' ) {
        if ( @$p == @$q ) {
            for my $i ( 0 .. $#{$p} ) {
                my @new_indices;
                ( $ok, $diag, @new_indices ) = _check( $p->[$i], $q->[$i], $epsilon, $name,
                    scalar @indices ? @indices : (), $i, );
                if ( not $ok ) {
                    @indices = @new_indices;
                    last;
                }
            }
        }
        else {
            $ok = 0;
            $diag =
                "Got an array of length "
              . scalar(@$p)
              . ", but expected an array of length "
              . scalar(@$q);
        }
    }
    else {
        $ok = abs( $p - $q ) < $epsilon;
        if ( !$ok ) {
            my ( $ep, $dp ) = _ep_dp($epsilon);
            $diag = sprintf( "%.${dp}f and %.${dp}f are not equal" . " to within %.${ep}f",
                $p, $q, $epsilon );
        }
    }
    return ( $ok, $diag, scalar(@indices) ? @indices : () );
}

sub _ep_dp {
    my $epsilon = shift;
    my ($exp) = sprintf( "%e", $epsilon ) =~ m/e(.+)/;
    my $ep = $exp < 0 ? -$exp : 1;
    my $dp = $ep + 1;
    return ( $ep, $dp );
}


#--------------------------------------------------------------------------#
# delta_within()
#--------------------------------------------------------------------------#


sub delta_within($$$;$) { ## no critic
    my ( $p, $q, $epsilon, $name ) = @_;
    croak "Value of epsilon to delta_within must be non-zero"
      if $epsilon == 0;
    $epsilon = abs($epsilon);
    my ( $ok, $diag, @indices ) = _check( $p, $q, $epsilon, $name );
    if (@indices) {
        $diag = "At [" . join( "][", @indices ) . "]: $diag";
    }
    return $Test->ok( $ok, $name ) || $Test->diag($diag);
}

#--------------------------------------------------------------------------#
# delta_ok()
#--------------------------------------------------------------------------#


sub delta_ok($$;$) { ## no critic
    my ( $p, $q, $name ) = @_;
    {
        local $Test::Builder::Level = $Test::Builder::Level + 1;
        my $e =
            $Relative
          ? $Relative * ( abs($p) > abs($q) ? abs($p) : abs($q) )
          : $Epsilon;
        delta_within( $p, $q, $e, $name );
    }
}

#--------------------------------------------------------------------------#
# delta_not_ok()
#--------------------------------------------------------------------------#


sub delta_not_within($$$;$) { ## no critic
    my ( $p, $q, $epsilon, $name ) = @_;
    croak "Value of epsilon to delta_not_within must be non-zero"
      if $epsilon == 0;
    $epsilon = abs($epsilon);
    my ( $ok, undef, @indices ) = _check( $p, $q, $epsilon, $name );
    $ok = !$ok;
    my ( $ep, $dp ) = _ep_dp($epsilon);
    my $diag = sprintf( "Arguments are equal to within %.${ep}f", $epsilon );
    return $Test->ok( $ok, $name ) || $Test->diag($diag);
}


sub delta_not_ok($$;$) { ## no critic
    my ( $p, $q, $name ) = @_;
    {
        local $Test::Builder::Level = $Test::Builder::Level + 1;
        my $e =
            $Relative
          ? $Relative * ( abs($p) > abs($q) ? abs($p) : abs($q) )
          : $Epsilon;
        delta_not_within( $p, $q, $e, $name );
    }
}

1;

__END__