File Coverage

blib/lib/Math/Complex_C/L.pm

Criterion	Covered	Total	%
statement	45	62	72.5
branch	22	48	45.8
condition	4	9	44.4
subroutine	9	9	100.0
pod	0	5	0.0
total	80	133	60.1

use strict;
use warnings;
package Math::Complex_C::L;

require Exporter;
*import = \&Exporter::import;
require DynaLoader;

use overload
    '**'    => \&_overload_pow,
    '*'     => \&_overload_mul,
    '+'     => \&_overload_add,
    '/'     => \&_overload_div,
    '-'     => \&_overload_sub,
    '**='   => \&_overload_pow_eq,
    '*='    => \&_overload_mul_eq,
    '+='    => \&_overload_add_eq,
    '/='    => \&_overload_div_eq,
    '-='    => \&_overload_sub_eq,
    'sqrt'  => \&_overload_sqrt,
    '=='    => \&_overload_equiv,
    '!='    => \&_overload_not_equiv,
    '!'     => \&_overload_not,
    'bool'  => \&_overload_true,
    '='     => \&_overload_copy,
    '""'    => \&_overload_string,
    'abs'   => \&_overload_abs,
    'exp'   => \&_overload_exp,
    'log'   => \&_overload_log,
    'sin'   => \&_overload_sin,
    'cos'   => \&_overload_cos,
    'atan2' => \&_overload_atan2,
;

our $VERSION = '0.06';

DynaLoader::bootstrap Math::Complex_C::L $VERSION;

@Math::Complex_C::L::EXPORT = ();
@Math::Complex_C::L::EXPORT_OK = qw(

    create_cl assign_cl mul_cl mul_c_nvl mul_c_ivl mul_c_uvl div_cl div_c_nvl div_c_ivl div_c_uvl add_cl
    add_c_nvl add_c_ivl add_c_uvl sub_cl sub_c_nvl sub_c_ivl sub_c_uvl real_cl real_cl2LD imag_cl2LD
    LD2cl cl2LD real_cl2str imag_cl2str arg_cl2LD arg_cl2str abs_cl2LD abs_cl2str
    imag_cl arg_cl abs_cl conj_cl acos_cl asin_cl atan_cl cos_cl sin_cl tan_cl acosh_cl asinh_cl atanh_cl
    cosh_cl sinh_cl tanh_cl exp_cl log_cl sqrt_cl proj_cl pow_cl
    get_nanl get_neg_infl get_infl is_nanl is_infl MCL
    add_c_pvl sub_c_pvl mul_c_pvl div_c_pvl

    str_to_l l_to_str l_to_strp l_set_prec l_get_prec set_real_cl set_imag_cl
    ld_to_str ld_to_strp long_set_prec long_get_prec
    );

%Math::Complex_C::L::EXPORT_TAGS = (all => [qw(

    create_cl assign_cl mul_cl mul_c_nvl mul_c_ivl mul_c_uvl div_cl div_c_nvl div_c_ivl div_c_uvl add_cl
    add_c_nvl add_c_ivl add_c_uvl sub_cl sub_c_nvl sub_c_ivl sub_c_uvl real_cl real_cl2LD imag_cl2LD
    LD2cl cl2LD real_cl2str imag_cl2str arg_cl2LD arg_cl2str abs_cl2LD abs_cl2str
    imag_cl arg_cl abs_cl conj_cl acos_cl asin_cl atan_cl cos_cl sin_cl tan_cl acosh_cl asinh_cl atanh_cl
    cosh_cl sinh_cl tanh_cl exp_cl log_cl sqrt_cl proj_cl pow_cl
    get_nanl get_neg_infl get_infl is_nanl is_infl MCL
    add_c_pvl sub_c_pvl mul_c_pvl div_c_pvl

    str_to_l l_to_str l_to_strp l_set_prec l_get_prec set_real_cl set_imag_cl
    ld_to_str ld_to_strp long_set_prec long_get_prec
    )]);

sub dl_load_flags {0} # Prevent DynaLoader from complaining and croaking

sub l_to_str {
    return join ' ', _l_to_str($_[0]);
}

sub l_to_strp {
    return join ' ', _l_to_strp($_[0], $_[1]);
}

sub str_to_l {
    my($re, $im) = split /\s+/, $_[0];
    $im = 0 if !defined($im);

    $re = get_nanl() if $re =~ /^(\+|\-)?nan/i;
    $im = get_nanl() if $im =~ /^(\+|\-)?nan/i;

    if($re =~ /^(\+|\-)?inf/i) {
      if($re =~ /^\-inf/i) {$re = get_neg_infl()}
      else {$re = get_infl()}
    }

    if($im =~ /^(\+|\-)?inf/i) {
      if($re =~ /^\-inf/i) {$im = get_neg_infl()}
      else {$im = get_infl()}
    }

    return MCL($re, $im);
}

sub _overload_string {
    my($real, $imag) = (real_cl($_[0]), imag_cl($_[0]));
    my($r, $i) = _l_to_str($_[0]);

    if($real == 0) {
      $r = $real =~ /^\-/ ? '-0' : '0';
    }
    elsif($real != $real) {
      $r = 'NaN';
    }
    elsif(($real / $real) != ($real / $real)) {
      $r = $real < 0 ? '-Inf' : 'Inf';
    }
    else {
      my @re = split /e/i, $r;
      while(substr($re[0], -1, 1) eq '0' && substr($re[0], -2, 1) ne '.') {
        chop $re[0];
      }
      $r = $re[0] . 'e' . $re[1];
    }

    if($imag == 0) {
      $i = $imag =~ /^\-/ ? '-0' : '0';
    }
    elsif($imag != $imag) {
      $i = 'NaN';
    }
    elsif(($imag / $imag) != ($imag / $imag)) {
      $i = $imag < 0 ? '-Inf' : 'Inf';
    }
    else {
      my @im = split /e/i, $i;
      while(substr($im[0], -1, 1) eq '0' && substr($im[0], -2, 1) ne '.') {
        chop $im[0];
      }
      $i = $im[0] . 'e' . $im[1];
    }

    return "(" . $r . " " . $i . ")";
}

sub new {


    # This function caters for 2 possibilities:
    # 1) that 'new' has been called OOP style - in which
    #    case there will be a maximum of 3 args
    # 2) that 'new' has been called as a function - in
    #    which case there will be a maximum of 2 args.
    # If there are no args, then we just want to return a
    # Math::Complex_C::L object

    if(!@_) {return create_cl()}

    if(@_ > 3) {die "Too many arguments supplied to new()"}

    # If 'new' has been called OOP style, the first arg is the string
    # "Math::Complex_C::L" which we don't need - so let's remove it.

    if(!ref($_[0]) && $_[0] eq "Math::Complex_C::L") {
      shift;
      if(!@_) {return create_cl()}
    }

    if(@_ > 2) {die "Bad argument list supplied to new()"}

    my $ret;

    if(@_ == 2) {
      $ret = create_cl();
      assign_cl($ret, $_[0], $_[1]);
    }
    else {
      return $_[0] if _itsa($_[0]) == 226;
      $ret = create_cl();
      assign_cl($ret, $_[0], 0.0);
    }

    return $ret;
}

*MCL		= \&Math::Complex_C::L::new;
*long_get_prec	= \&l_get_prec; # for backwards-compatibility
*long_set_prec	= \&l_set_prec; # for backwards-compatibility
*ld_to_str	= \&l_to_str;	# for backwards-compatibility
*ld_to_strp	= \&l_to_strp;	# for backwards-compatibility

1;

__END__