1#!/usr/bin/perl -w 2# Tests for Number::WithError 3use strict; 4use lib (); 5use File::Spec::Functions ':ALL'; 6BEGIN { 7 $| = 1; 8 unless ( $ENV{HARNESS_ACTIVE} ) { 9 require FindBin; 10 $FindBin::Bin = $FindBin::Bin; # Avoid a warning 11 chdir catdir( $FindBin::Bin, updir() ); 12 lib->import( 13 catdir('blib', 'lib'), 14 'lib', 15 ); 16 } 17} 18 19use Test::More tests => 612; 20 21 22##################################################################### 23 24use Number::WithError qw/:all/; 25 26my @test_args = ( 27 { 28 name => 'integer', 29 args => [qw(5)], 30 obj => { num => '5', errors => [] }, 31 }, 32 { 33 name => 'decimal', 34 args => [qw(0.1)], 35 obj => { num => '0.1', errors => [] }, 36 }, 37 { 38 name => 'scientific', 39 args => [qw(0.001e-15)], 40 obj => { num => '0.001e-15', errors => [] }, 41 }, 42 { 43 name => 'scientific with error', 44 args => [qw(155e2 12)], 45 obj => { num => '155e2', errors => [12] }, 46 }, 47 { 48 name => 'integer with 3 errors', 49 args => [qw(5 0 3 1.2)], 50 obj => { num => '5', errors => [0, 3, 1.2] }, 51 }, 52 { 53 name => 'decimal with 4 errors', 54 args => [qw(0.1 0.1 0.1 0.1 0.1)], 55 obj => { num => '0.1', errors => [0.1, 0.1, 0.1, 0.1] }, 56 }, 57 { 58 name => 'scientific with 3 errors incl unbalanced', 59 args => [qw(3.4e5 2), [0.3, 0.5], 2], 60 obj => { num => '3.4e5', errors => [2, [0.3,0.5], 2] }, 61 }, 62 { 63 name => 'decimal with undef error and 1 error', 64 args => [qw(.4), undef, 0.1], 65 obj => { num => '0.4', errors => [undef, 0.1] }, 66 }, 67 { 68 name => 'string with 1 error', 69 args => ['2.0e-3 +/- 0.1e-3'], 70 obj => { num => '2.0e-3', errors => [0.1e-3] }, 71 }, 72 { 73 name => 'string with 1 error (2)', 74 args => ['2.0e-3+/-0.1e-3'], 75 obj => { num => '2.0e-3', errors => [0.1e-3] }, 76 }, 77 { 78 name => 'string with 1 error (3)', 79 args => ['2.0e-3+ /-0.1e-3'], 80 obj => { num => '2.0e-3', errors => [0.1e-3] }, 81 }, 82 { 83 name => 'string with 1 error (4)', 84 args => ['2.0e-3+/- 0.1e-3'], 85 obj => { num => '2.0e-3', errors => [0.1e-3] }, 86 }, 87 { 88 name => 'string with 2 errors', 89 args => ['2.0e-3 +/-0.1e-3+/--0.3e+1'], 90 obj => { num => '2.0e-3', errors => [0.1e-3, 0.3e+1] }, 91 }, 92 { 93 name => 'string with 2 errors incl unbalanced', 94 args => ['2.0e-3 +/- 0.1e-3 +0.15e-3 -0.01e-3'], 95 obj => { num => '2.0e-3', errors => [0.1e-3, [0.15e-3, 0.01e-3]]}, 96 }, 97 { 98 name => 'string with 2 errors incl unbalanced (2)', 99 args => ['2.0e-3 +/- 0.1e-3 -0.15e-3+0.01e-3'], 100 obj => { num => '2.0e-3', errors => [0.1e-3, [0.01e-3, 0.15e-3]]}, 101 }, 102 { 103 name => 'string with 2 errors incl unbalanced (3)', 104 args => ['2.0e-3+/-0.1e-3+0.15e-3-0.01e-3'], 105 obj => { num => '2.0e-3', errors => [0.1e-3, [0.15e-3, 0.01e-3]]}, 106 }, 107); 108 109# simple cases 110ok( not defined Number::WithError->new() ); 111ok( not defined Number::WithError->new(undef) ); 112ok( not defined Number::WithError->new_big() ); 113ok( not defined Number::WithError->new_big(undef) ); 114ok( not defined witherror() ); 115ok( not defined witherror(undef) ); 116ok( not defined witherror_big() ); 117ok( not defined witherror_big(undef) ); 118 119sub test_construction_method { 120 my $name = shift; 121 my $is_big = shift; 122 my $constructor = shift; 123 my $cloner = shift; 124 my $test_args = shift; 125 126 foreach (@$test_args) { 127 print "Testing $name with $_->{name}.\n"; 128 my $o = $_->{obj}; 129 my $args = $_->{args}; 130 my $name = $_->{name}; 131 132 my $num = $constructor->(@$args); 133 134 isa_ok($num, 'Number::WithError'); 135 isa_ok($num->{num}, 'Math::BigFloat') if $is_big; 136 ok(abs($num->{num}-$o->{num})<1e-24, $name); 137 ok(@{$num->{errors}} == @{$o->{errors}}, $name. '; number of errors'); 138 foreach (0..$#{$o->{errors}}) { 139 my $err = $o->{errors}[$_]; 140 if (ref($err) eq 'ARRAY') { 141 if ($is_big) { 142 my $errno = $_; 143 isa_ok($num->{errors}[$errno][$_], 'Math::BigFloat') for 0..$#{$num->{errors}[$errno]}; 144 } 145 ok(abs($err->[0]-$num->{errors}[$_][0])<1e-24, $name.'; error '.$_.'-1'); 146 ok(abs($err->[1]-$num->{errors}[$_][1])<1e-24, $name.'; error '.$_.'-2'); 147 } 148 else { 149 if (not defined $err) { 150 ok(not(defined $num->{errors}[$_])||abs($num->{errors}[$_])<1e-24, $name.'; error '.$_); 151 } 152 else { 153 isa_ok($num->{errors}[$_], 'Math::BigFloat') if $is_big; 154 ok(abs($err-$num->{errors}[$_])<1e-24, $name.'; error '.$_); 155 } 156 } 157 } 158 # test cloning: 159 my $copy = $cloner->($num); 160 is($copy, $num, $name . '; cloning'); 161 ok( overload::StrVal($copy) ne overload::StrVal($num), '; ref not equal after cloning'); 162 ok( ''.$copy->{errors} ne ''.$num->{errors}, '; {error} ref not equal after cloning'); 163 foreach (0..$#{$num->{errors}}) { 164 next if not ref($num->{errors}[$_]) eq 'ARRAY'; 165 ok($num->{errors}[$_] ne $copy->{errors}[$_], $name . "; Error no. $_, reference not equal after cloning"); 166 } 167 } 168 169} 170 171# test new() 172test_construction_method( 173 "->new()", 174 0, # not a big variant 175 sub {Number::WithError->new(@_)}, # const 176 sub {my $self = shift; $self->new(@_)}, # clone 177 \@test_args 178); 179 180# test witherror() 181test_construction_method( 182 "witherror()", 183 0, # not a big variant 184 sub {witherror(@_)}, # const 185 sub {my $self = shift; $self->new(@_);}, # clone 186 \@test_args 187); 188 189# test new_big() 190test_construction_method( 191 "->new_big()", 192 1, # is big 193 sub {Number::WithError->new_big(@_)}, # const 194 sub {my $self = shift; $self->new_big(@_);}, # clone 195 \@test_args 196); 197 198# test witherror_big() 199test_construction_method( 200 "witherror_big()", 201 1, # is big 202 sub {witherror_big(@_)}, # const 203 sub {my $self = shift; $self->new_big(@_);}, # clone 204 \@test_args 205); 206 207 208 209 210 211 2121; 213