File Coverage

blib/lib/Test/LimitDecimalPlaces.pm

Criterion	Covered	Total	%
statement	82	82	100.0
branch	24	24	100.0
condition	8	12	66.6
subroutine	15	15	100.0
pod	4	4	100.0
total	133	137	97.0

package Test::LimitDecimalPlaces;

use warnings;
use strict;
use Carp;
use Exporter;
use Test::Builder;

use vars qw/ $VERSION @EXPORT @ISA /;

BEGIN {
    $VERSION = '0.01';
    @ISA     = qw/ Exporter /;
    @EXPORT  = qw/ limit_ok limit_ok_by limit_not_ok limit_not_ok_by /;
}

my $TestBuilder           = Test::Builder->new;
my $default_num_of_digits = 7;

sub import {
    my $self  = shift;
    my $pack  = caller;
    my $found = grep /num_of_digits/, @_;

    if ($found) {
        my ( $key, $value ) = splice @_, 0, 2;

        if ( $value < 0 ) {
            croak 'Value of limit number of digits must be a number greater than or equal to zero.';
        }
        unless ( $key eq 'num_of_digits' ) {
            croak 'Test::LimitDecimalPlaces option must be specified first.';
        }
        $default_num_of_digits = $value;
    }

    $TestBuilder->exported_to($pack);
    $TestBuilder->plan(@_);
    $self->export_to_level( 1, $self, $_ ) for @EXPORT;
}

sub _construct_err_msg {
    my ( $x, $y, $num_of_digits ) = @_;

    return
        sprintf( "%.${num_of_digits}f", $x ) . ' and '
      . sprintf( "%.${num_of_digits}f", $y )
      . ' are not equal by limiting decimal places is ' . $num_of_digits;
}

sub _check {
    my ( $x, $y, $num_of_digits ) = @_;

    my $is_array = 0;

    croak 'Value of limit number of digits must be a number '
      . 'greater than or equal to zero.' if ( $num_of_digits < 0 );
    $num_of_digits = int($num_of_digits);

    my ($ok, $diag) = (1, '');

    if (ref $x eq 'ARRAY' || ref $y eq 'ARRAY') {
        $is_array = 1;
        unless (scalar(@$x) == scalar(@$y)) {
            $ok = 0;
            $diag = "Got length of an array is " . scalar(@$x) .
                    ", but expected length of an array is " . scalar(@$y);
            return ($ok, $diag);
        }
    }

    if ($is_array) {
        for my $i ( 0 .. $#$x ) {
            ($ok, $diag) = _check($x->[$i], $y->[$i], $num_of_digits);
            unless ($ok) {
                $diag .= ', number of element is ' . $i . ' in array';
                last;
            }
        }
    } else {
        $ok = (
            sprintf( "%.${num_of_digits}f", $x ) ==
              sprintf( "%.${num_of_digits}f", $y ) );
        $diag = _construct_err_msg( $x, $y, $num_of_digits ) unless ($ok);
    }

    return ( $ok, $diag );
}

sub _flip {
    my ( $state, $x, $y, $num_of_digits, $is_array ) = @_;

    $state = !$state;
    my $diag;
    unless ($state) {
        if ($is_array) {
            $diag = 'Both of arrays are the same.';
        } else {
            $diag = _construct_err_msg( $x, $y, $num_of_digits );
            $diag =~ s/ not//;
        }
    }

    return ( $state, $diag );
}

sub limit_ok_by($$$;$) {
    my ( $x, $y, $num_of_digits, $test_name ) = @_;

    my ( $ok, $diag ) = _check( $x, $y, $num_of_digits, $test_name );
    return $TestBuilder->ok( $ok, $test_name ) || $TestBuilder->diag($diag);
}

sub limit_ok($$;$) {
    my ( $x, $y, $test_name ) = @_;

    {
        local $Test::Builder::Level = $Test::Builder::Level + 1;
        limit_ok_by( $x, $y, $default_num_of_digits, $test_name );
    }
}

sub limit_not_ok_by($$$;$) {
    my ( $x, $y, $num_of_digits, $test_name ) = @_;

    my $is_array = 0;
    $is_array = 1 if (ref $x eq 'ARRAY' || ref $y eq 'ARRAY' );

    my ( $ok, $diag ) = _check( $x, $y, $num_of_digits, $test_name );
    ( $ok, $diag ) = _flip( $ok, $x, $y, $num_of_digits, $is_array );
    return $TestBuilder->ok( $ok, $test_name ) || $TestBuilder->diag($diag);
}

sub limit_not_ok($$;$) {
    my ( $x, $y, $test_name ) = @_;

    {
        local $Test::Builder::Level = $Test::Builder::Level + 1;
        limit_not_ok_by( $x, $y, $default_num_of_digits, $test_name );
    }
}

1;
__END__