t/Deriv.t

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