1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
|
package Math::GSL::Deriv::Test;
use base 'Test::Class';
use Test::More tests => 13;
use Math::GSL qw/:all/;
use Math::GSL::Test qw/:all/;
use Math::GSL::Deriv qw/:all/;
use Math::GSL::Errno qw/:all/;
use Test::Exception;
use Data::Dumper;
use strict;
BEGIN{ gsl_set_error_handler_off() };
sub make_fixture : Test(setup) {
my $self = shift;
$self->{gsl_func} = Math::GSL::Deriv::gsl_function_struct->new;
}
sub teardown : Test(teardown) {
}
sub TEST_FUNCTION_STRUCT : Tests(1) {
my $self = shift;
isa_ok( $self->{gsl_func},'Math::GSL::Deriv::gsl_function_struct');
}
sub TEST_DERIV_CENTRAL_DIES : Tests(5) {
my ($x,$h)=(10,0.01);
throws_ok( sub {
gsl_deriv_central( 'IAMNOTACODEREF', $x, $h);
},qr/Undefined subroutine/, 'gsl_deriv_central borks when first arg is not a existing routine');
throws_ok( sub {
gsl_deriv_central( undef, $x, $h);
},qr/not a reference to code/, 'gsl_deriv_central borks when first arg is undef');
throws_ok( sub {
gsl_deriv_central( {}, $x, $h);
},qr/not a reference to code/, 'gsl_deriv_central borks when first arg is hash ref');
throws_ok( sub {
gsl_deriv_central( [], $x, $h);
},qr/is an empty array/, 'gsl_deriv_central borks when first arg is an empty array ref');
throws_ok( sub {
gsl_deriv_central( 'IAMNOTACODEREF', $x, $h);
},qr/Undefined subroutine/, 'gsl_deriv_central borks when first arg is not a existing routine');
}
sub TEST_DERIV_CENTRAL : Tests(2) {
my $self = shift;
my ($x,$h)=(10,0.01);
my ($status, $val,$err) = gsl_deriv_central ( sub { $_[0] ** 3 }, $x, $h,);
ok_status($status);
my $res = abs($val-3*$x**2);
ok( $res <= $err , sprintf ("gsl_deriv_forward: res=%.18f, abserr=%.18f",$res, $err ));
}
sub TEST_DERIV_FORWARD : Tests(2) {
my $self = shift;
my ($x,$h)=(10,0.01);
my ($status, $val,$err) = gsl_deriv_forward ( sub { 2 * $_[0] ** 2 }, $x, $h,);
ok_status($status);
my $res = abs($val-4*$x);
ok( $res <= $err , sprintf ("gsl_deriv_forward: res=%.18f, abserr=%.18f",$res, $err ));
}
sub TEST_DERIV_BACKWARD : Tests(2) {
my $self = shift;
my ($x,$h)=(10,0.01);
my ($status, $val, $err) = gsl_deriv_backward ( sub { log $_[0] }, $x, $h,);
ok_status($status);
my $res = abs($val-1/$x);
ok( $res <= $err , sprintf ("gsl_deriv_backward: res=%.18f, abserr=%.18f",$res, $err ));
}
sub TEST_DERIV_CENTRAL_CALLS_THE_SUB : Tests(1) {
my $self = shift;
my ($x,$h)=(10,0.01);
throws_ok( sub {
gsl_deriv_central ( sub { die "CALL ME BACK!"} , $x, $h)
}, qr/CALL ME BACK/, 'gsl_deriv_central can call anon sub' );
}
Test::Class->runtests;
|
