File Coverage

blib/lib/Math/Complex_C/Q.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


line stmt bran cond sub pod time code
1 15     15   6136 use strict;
  15         16  
  15         350  
2 15     15   55 use warnings;
  15         16  
  15         2654  
3             package Math::Complex_C::Q;
4              
5             require Exporter;
6             *import = \&Exporter::import;
7             require DynaLoader;
8              
9             use overload
10 15         237 '**' => \&_overload_pow,
11             '*' => \&_overload_mul,
12             '+' => \&_overload_add,
13             '/' => \&_overload_div,
14             '-' => \&_overload_sub,
15             '**=' => \&_overload_pow_eq,
16             '*=' => \&_overload_mul_eq,
17             '+=' => \&_overload_add_eq,
18             '/=' => \&_overload_div_eq,
19             '-=' => \&_overload_sub_eq,
20             'sqrt' => \&_overload_sqrt,
21             '==' => \&_overload_equiv,
22             '!=' => \&_overload_not_equiv,
23             '!' => \&_overload_not,
24             'bool' => \&_overload_true,
25             '=' => \&_overload_copy,
26             '""' => \&_overload_string,
27             'abs' => \&_overload_abs,
28             'exp' => \&_overload_exp,
29             'log' => \&_overload_log,
30             'sin' => \&_overload_sin,
31             'cos' => \&_overload_cos,
32             'atan2' => \&_overload_atan2,
33 15     15   12754 ;
  15         11200  
34              
35             our $VERSION = '0.06';
36              
37             DynaLoader::bootstrap Math::Complex_C::Q $VERSION;
38              
39             @Math::Complex_C::Q::EXPORT = ();
40             @Math::Complex_C::Q::EXPORT_OK = qw(
41              
42             create_cq assign_cq mul_cq mul_c_nvq mul_c_ivq mul_c_uvq div_cq div_c_nvq div_c_ivq div_c_uvq add_cq
43             add_c_nvq add_c_ivq add_c_uvq sub_cq sub_c_nvq sub_c_ivq sub_c_uvq real_cq real_cq2F imag_cq2F F2cq
44             cq2F real_cq2str imag_cq2str arg_cq2F arg_cq2str abs_cq2F abs_cq2str
45             imag_cq arg_cq abs_cq conj_cq acos_cq asin_cq atan_cq cos_cq sin_cq tan_cq acosh_cq asinh_cq atanh_cq
46             cosh_cq sinh_cq tanh_cq exp_cq log_cq sqrt_cq proj_cq pow_cq
47             get_nanq get_neg_infq get_infq is_nanq is_infq MCQ
48             add_c_pvq sub_c_pvq mul_c_pvq div_c_pvq
49              
50             str_to_q q_to_str q_to_strp q_set_prec q_get_prec set_real_cq set_imag_cq
51             );
52              
53             %Math::Complex_C::Q::EXPORT_TAGS = (all => [qw(
54              
55             create_cq assign_cq mul_cq mul_c_nvq mul_c_ivq mul_c_uvq div_cq div_c_nvq div_c_ivq div_c_uvq add_cq
56             add_c_nvq add_c_ivq add_c_uvq sub_cq sub_c_nvq sub_c_ivq sub_c_uvq real_cq real_cq2F imag_cq2F F2cq
57             cq2F real_cq2str imag_cq2str arg_cq2F arg_cq2str abs_cq2F abs_cq2str
58             imag_cq arg_cq abs_cq conj_cq acos_cq asin_cq atan_cq cos_cq sin_cq tan_cq acosh_cq asinh_cq atanh_cq
59             cosh_cq sinh_cq tanh_cq exp_cq log_cq sqrt_cq proj_cq pow_cq
60             get_nanq get_infq get_neg_infq is_nanq is_infq MCQ
61             add_c_pvq sub_c_pvq mul_c_pvq div_c_pvq
62              
63             str_to_q q_to_str q_to_strp q_set_prec q_get_prec set_real_cq set_imag_cq
64             )]);
65              
66 15     15 0 7632 sub dl_load_flags {0} # Prevent DynaLoader from complaining and croaking
67              
68             sub q_to_str {
69 6     6 0 43 return join ' ', _q_to_str($_[0]);
70             }
71              
72             sub q_to_strp {
73 3     3 0 17 return join ' ', _q_to_strp($_[0], $_[1]);
74             }
75              
76             sub str_to_q {
77 1     1 0 6 my($re, $im) = split /\s+/, $_[0];
78 1 50       3 $im = 0 if !defined($im);
79              
80 1 50       4 $re = get_nanq() if $re =~ /^(\+|\-)?nan/i;
81 1 50       3 $im = get_nanq() if $im =~ /^(\+|\-)?nan/i;
82              
83 1 50       5 if($re =~ /^(\+|\-)?inf/i) {
84 0 0       0 if($re =~ /^\-inf/i) {$re = get_neg_infq()}
  0         0  
85 0         0 else {$re = get_infq()}
86             }
87              
88 1 50       3 if($im =~ /^(\+|\-)?inf/i) {
89 0 0       0 if($re =~ /^\-inf/i) {$im = get_neg_infq()}
  0         0  
90 0         0 else {$im = get_infq()}
91             }
92              
93 1         3 return MCQ($re, $im);
94             }
95              
96             sub _overload_string {
97 7     7   105 my($real, $imag) = (real_cq($_[0]), imag_cq($_[0]));
98 7         56 my($r, $i) = _q_to_str($_[0]);
99              
100 7 50       21 if($real == 0) {
    100          
    50          
101 0 0       0 $r = $real =~ /^\-/ ? '-0' : '0';
102             }
103             elsif($real != $real) {
104 4         4 $r = 'NaN';
105             }
106             elsif(($real / $real) != ($real / $real)) {
107 0 0       0 $r = $real < 0 ? '-Inf' : 'Inf';
108             }
109             else {
110 3         9 my @re = split /e/i, $r;
111 3   33     8 while(substr($re[0], -1, 1) eq '0' && substr($re[0], -2, 1) ne '.') {
112 0         0 chop $re[0];
113             }
114 3         6 $r = $re[0] . 'e' . $re[1];
115             }
116              
117 7 50       23 if($imag == 0) {
    100          
    50          
118 0 0       0 $i = $imag =~ /^\-/ ? '-0' : '0';
119             }
120             elsif($imag != $imag) {
121 4         4 $i = 'NaN';
122             }
123             elsif(($imag / $imag) != ($imag / $imag)) {
124 0 0       0 $i = $imag < 0 ? '-Inf' : 'Inf';
125             }
126             else {
127 3         4 my @im = split /e/i, $i;
128 3   33     7 while(substr($im[0], -1, 1) eq '0' && substr($im[0], -2, 1) ne '.') {
129 0         0 chop $im[0];
130             }
131 3         4 $i = $im[0] . 'e' . $im[1];
132             }
133              
134 7         21 return "(" . $r . " " . $i . ")";
135             }
136              
137             sub new {
138              
139              
140             # This function caters for 2 possibilities:
141             # 1) that 'new' has been called OOP style - in which
142             # case there will be a maximum of 3 args
143             # 2) that 'new' has been called as a function - in
144             # which case there will be a maximum of 2 args.
145             # If there are no args, then we just want to return a
146             # Math::Complex_C::Q object
147              
148 63 100   63 0 1720 if(!@_) {return create_cq()}
  9         52  
149              
150 54 50       87 if(@_ > 3) {die "Too many arguments supplied to new()"}
  0         0  
151              
152             # If 'new' has been called OOP style, the first arg is the string
153             # "Math::Complex_C::Q" which we don't need - so let's remove it.
154              
155 54 100 66     266 if(!ref($_[0]) && $_[0] eq "Math::Complex_C::Q") {
156 10         11 shift;
157 10 100       21 if(!@_) {return create_cq()}
  2         25  
158             }
159              
160 52 50       115 if(@_ > 2) {die "Bad argument list supplied to new()"}
  0         0  
161              
162 52         38 my $ret;
163              
164 52 50       75 if(@_ == 2) {
165 52         334 $ret = create_cq();
166 52         175 assign_cq($ret, $_[0], $_[1]);
167             }
168             else {
169 0 0       0 return $_[0] if _itsa($_[0]) == 226;
170 0         0 $ret = create_cq();
171 0         0 assign_cq($ret, $_[0], 0.0);
172             }
173              
174 52         218 return $ret;
175             }
176              
177             *MCQ = \&Math::Complex_C::Q::new;
178              
179             1;
180              
181             __END__