File Coverage

blib/lib/bigfloat.pm
Criterion Covered Total %
statement 122 160 76.2
branch 40 72 55.5
condition 4 20 20.0
subroutine 28 33 84.8
pod 15 15 100.0
total 209 300 69.6


line stmt bran cond sub pod time code
1             package bigfloat;
2              
3 15     15   461828 use strict;
  15         89  
  15         384  
4 15     15   66 use warnings;
  15         26  
  15         444  
5              
6 15     15   74 use Carp qw< carp croak >;
  15         31  
  15         841  
7              
8             our $VERSION = '0.66';
9              
10 15     15   87 use Exporter;
  15         41  
  15         1117  
11             our @ISA = qw( Exporter );
12             our @EXPORT_OK = qw( PI e bpi bexp hex oct );
13             our @EXPORT = qw( inf NaN );
14              
15 15     15   8474 use overload;
  15         7514  
  15         90  
16              
17             my $obj_class = "Math::BigFloat";
18              
19             ##############################################################################
20              
21             sub accuracy {
22 5     5 1 10417 my $self = shift;
23 5         24 $obj_class -> accuracy(@_);
24             }
25              
26             sub precision {
27 5     5 1 4125 my $self = shift;
28 5         25 $obj_class -> precision(@_);
29             }
30              
31             sub round_mode {
32 5     5 1 1673 my $self = shift;
33 5         21 $obj_class -> round_mode(@_);
34             }
35              
36             sub div_scale {
37 0     0 1 0 my $self = shift;
38 0         0 $obj_class -> div_scale(@_);
39             }
40              
41             sub upgrade {
42 0     0 1 0 my $self = shift;
43 0         0 $obj_class -> upgrade(@_);
44             }
45              
46             sub downgrade {
47 0     0 1 0 my $self = shift;
48 0         0 $obj_class -> downgrade(@_);
49             }
50              
51             sub in_effect {
52 6   50 6 1 23 my $level = shift || 0;
53 6         42 my $hinthash = (caller($level))[10];
54 6         26 $hinthash->{bigfloat};
55             }
56              
57             sub _float_constant {
58 10     10   32 my $str = shift;
59              
60             # See if we can convert the input string to a string using a normalized form
61             # consisting of the significand as a signed integer, the character "e", and
62             # the exponent as a signed integer, e.g., "+0e+0", "+314e-2", and "-1e+3".
63              
64 10         15 my $nstr;
65              
66 10 0 33     65 if (
      33        
      0        
      33        
      0        
      0        
67             # See if it is an octal number. An octal number like '0377' is also
68             # accepted by the functions parsing decimal and hexadecimal numbers, so
69             # handle octal numbers before decimal and hexadecimal numbers.
70              
71             $str =~ /^0(?:[Oo]|_*[0-7])/ and
72             $nstr = Math::BigInt -> oct_str_to_dec_flt_str($str)
73              
74             or
75              
76             # See if it is decimal number.
77              
78             $nstr = Math::BigInt -> dec_str_to_dec_flt_str($str)
79              
80             or
81              
82             # See if it is a hexadecimal number. Every hexadecimal number has a
83             # prefix, but the functions parsing numbers don't require it, so check
84             # to see if it actually is a hexadecimal number.
85              
86             $str =~ /^0[Xx]/ and
87             $nstr = Math::BigInt -> hex_str_to_dec_flt_str($str)
88              
89             or
90              
91             # See if it is a binary numbers. Every binary number has a prefix, but
92             # the functions parsing numbers don't require it, so check to see if it
93             # actually is a binary number.
94              
95             $str =~ /^0[Bb]/ and
96             $nstr = Math::BigInt -> bin_str_to_dec_flt_str($str))
97             {
98 10         1463 return $obj_class -> new($nstr);
99             }
100              
101             # If we get here, there is a bug in the code above this point.
102              
103 0         0 warn "Internal error: unable to handle literal constant '$str'.",
104             " This is a bug, so please report this to the module author.";
105 0         0 return $obj_class -> bnan();
106             }
107              
108             #############################################################################
109             # the following two routines are for "use bigfloat qw/hex oct/;":
110              
111 15     15   5751 use constant LEXICAL => $] > 5.009004;
  15         32  
  15         9563  
112              
113             # Internal function with the same semantics as CORE::hex(). This function is
114             # not used directly, but rather by other front-end functions.
115              
116             sub _hex_core {
117 24     24   43 my $str = shift;
118              
119             # Strip off, clean, and parse as much as we can from the beginning.
120              
121 24         25 my $x;
122 24 50       133 if ($str =~ s/ ^ ( 0? [xX] )? ( [0-9a-fA-F]* ( _ [0-9a-fA-F]+ )* ) //x) {
123 24         240 my $chrs = $2;
124 24         45 $chrs =~ tr/_//d;
125 24 50       53 $chrs = '0' unless CORE::length $chrs;
126 24         77 $x = $obj_class -> from_hex($chrs);
127             } else {
128 0         0 $x = $obj_class -> bzero();
129             }
130              
131             # Warn about trailing garbage.
132              
133 24 50       4631 if (CORE::length($str)) {
134 0         0 require Carp;
135 0         0 Carp::carp(sprintf("Illegal hexadecimal digit '%s' ignored",
136             substr($str, 0, 1)));
137             }
138              
139 24         127 return $x;
140             }
141              
142             # Internal function with the same semantics as CORE::oct(). This function is
143             # not used directly, but rather by other front-end functions.
144              
145             sub _oct_core {
146 24     24   43 my $str = shift;
147              
148 24         69 $str =~ s/^\s*//;
149              
150             # Hexadecimal input.
151              
152 24 50       217 return _hex_core($str) if $str =~ /^0?[xX]/;
153              
154 24         30 my $x;
155              
156             # Binary input.
157              
158 24 50       52 if ($str =~ /^0?[bB]/) {
159              
160             # Strip off, clean, and parse as much as we can from the beginning.
161              
162 0 0       0 if ($str =~ s/ ^ ( 0? [bB] )? ( [01]* ( _ [01]+ )* ) //x) {
163 0         0 my $chrs = $2;
164 0         0 $chrs =~ tr/_//d;
165 0 0       0 $chrs = '0' unless CORE::length $chrs;
166 0         0 $x = $obj_class -> from_bin($chrs);
167             }
168              
169             # Warn about trailing garbage.
170              
171 0 0       0 if (CORE::length($str)) {
172 0         0 require Carp;
173 0         0 Carp::carp(sprintf("Illegal binary digit '%s' ignored",
174             substr($str, 0, 1)));
175             }
176              
177 0         0 return $x;
178             }
179              
180             # Octal input. Strip off, clean, and parse as much as we can from the
181             # beginning.
182              
183 24 50       91 if ($str =~ s/ ^ ( 0? [oO] )? ( [0-7]* ( _ [0-7]+ )* ) //x) {
184 24         50 my $chrs = $2;
185 24         32 $chrs =~ tr/_//d;
186 24 50       47 $chrs = '0' unless CORE::length $chrs;
187 24         73 $x = $obj_class -> from_oct($chrs);
188             }
189              
190             # Warn about trailing garbage. CORE::oct() only warns about 8 and 9, but it
191             # is more helpful to warn about all invalid digits.
192              
193 24 50       4920 if (CORE::length($str)) {
194 0         0 require Carp;
195 0         0 Carp::carp(sprintf("Illegal octal digit '%s' ignored",
196             substr($str, 0, 1)));
197             }
198              
199 24         109 return $x;
200             }
201              
202             {
203             my $proto = LEXICAL ? '_' : ';$';
204 0 0   0 1 0 eval '
  0         0  
205             sub hex(' . $proto . ') {' . <<'.';
206             my $str = @_ ? $_[0] : $_;
207             _hex_core($str);
208             }
209             .
210              
211 0 0   0 1 0 eval '
  0         0  
212             sub oct(' . $proto . ') {' . <<'.';
213             my $str = @_ ? $_[0] : $_;
214             _oct_core($str);
215             }
216             .
217             }
218              
219             #############################################################################
220             # the following two routines are for Perl 5.9.4 or later and are lexical
221              
222             my ($prev_oct, $prev_hex, $overridden);
223              
224 40 100   40   3510 if (LEXICAL) { eval <<'.' }
  40 50   40   641  
  40 50       170  
  40 100       598  
    100          
    50          
    50          
    100          
225             sub _hex(_) {
226             my $hh = (caller 0)[10];
227             return $$hh{bigfloat} ? bigfloat::_hex_core($_[0])
228             : $$hh{bigrat} ? bigrat::_hex_core($_[0])
229             : $$hh{bigint} ? bigint::_hex_core($_[0])
230             : $prev_hex ? &$prev_hex($_[0])
231             : CORE::hex($_[0]);
232             }
233              
234             sub _oct(_) {
235             my $hh = (caller 0)[10];
236             return $$hh{bigfloat} ? bigfloat::_oct_core($_[0])
237             : $$hh{bigrat} ? bigrat::_oct_core($_[0])
238             : $$hh{bigint} ? bigint::_oct_core($_[0])
239             : $prev_oct ? &$prev_oct($_[0])
240             : CORE::oct($_[0]);
241             }
242             .
243              
244             sub _override {
245 57 100   57   132 return if $overridden;
246 15         37 $prev_oct = *CORE::GLOBAL::oct{CODE};
247 15         21 $prev_hex = *CORE::GLOBAL::hex{CODE};
248 15     15   102 no warnings 'redefine';
  15         28  
  15         13268  
249 15         41 *CORE::GLOBAL::oct = \&_oct;
250 15         30 *CORE::GLOBAL::hex = \&_hex;
251 15         26 $overridden = 1;
252             }
253              
254             sub unimport {
255 14     14   1433 $^H{bigfloat} = undef; # no longer in effect
256 14         41 overload::remove_constant('binary', '', 'float', '', 'integer');
257             }
258              
259             sub import {
260 57     57   47829 my $class = shift;
261              
262 57         172 $^H{bigfloat} = 1; # we are in effect
263 57         122 $^H{bigint} = undef;
264 57         94 $^H{bigrat} = undef;
265              
266             # for newer Perls always override hex() and oct() with a lexical version:
267 57         67 if (LEXICAL) {
268 57         101 _override();
269             }
270              
271 57         80 my @import = ();
272 57         82 my @a = (); # unrecognized arguments
273 57         63 my $ver; # version?
274              
275 57         140 while (@_) {
276 39         54 my $param = shift;
277              
278             # Accuracy.
279              
280 39 100       91 if ($param =~ /^a(ccuracy)?$/) {
281 2         5 push @import, 'accuracy', shift();
282 2         6 next;
283             }
284              
285             # Precision.
286              
287 37 100       68 if ($param =~ /^p(recision)?$/) {
288 2         4 push @import, 'precision', shift();
289 2         5 next;
290             }
291              
292             # Rounding mode.
293              
294 35 50       64 if ($param eq 'round_mode') {
295 0         0 push @import, 'round_mode', shift();
296 0         0 next;
297             }
298              
299             # Backend library.
300              
301 35 100       105 if ($param =~ /^(l|lib|try|only)$/) {
302 9 100       22 push @import, $param eq 'l' ? 'lib' : $param;
303 9 50       20 push @import, shift() if @_;
304 9         22 next;
305             }
306              
307 26 50       62 if ($param =~ /^(v|version)$/) {
308 0         0 $ver = 1;
309 0         0 next;
310             }
311              
312 26 50       48 if ($param =~ /^(t|trace)$/) {
313 0         0 $obj_class .= "::Trace";
314 0         0 eval "require $obj_class";
315 0 0       0 die $@ if $@;
316 0         0 next;
317             }
318              
319 26 100       67 if ($param =~ /^(PI|e|bexp|bpi|hex|oct)\z/) {
320 6         9 push @a, $param;
321 6         10 next;
322             }
323              
324 20         1800 croak("Unknown option '$param'");
325             }
326              
327 37         1995 eval "require $obj_class";
328 37 50       642522 die $@ if $@;
329 37         172 $obj_class -> import(@import);
330              
331 37 50       182476 if ($ver) {
332 0         0 printf "%-31s v%s\n", $class, $class -> VERSION();
333 0         0 printf " lib => %-23s v%s\n",
334             $obj_class -> config("lib"), $obj_class -> config("lib_version");
335 0         0 printf "%-31s v%s\n", $obj_class, $obj_class -> VERSION();
336 0         0 exit;
337             }
338              
339 37         1394 $class -> export_to_level(1, $class, @a); # export inf, NaN, etc.
340              
341             overload::constant
342              
343             # This takes care each number written as decimal integer and within the
344             # range of what perl can represent as an integer, e.g., "314", but not
345             # "3141592653589793238462643383279502884197169399375105820974944592307".
346              
347             integer => sub {
348             #printf "Value '%s' handled by the 'integer' sub.\n", $_[0];
349 59     59   17626 my $str = shift;
350 59         183 return $obj_class -> new($str);
351             },
352              
353             # This takes care of each number written with a decimal point and/or
354             # using floating point notation, e.g., "3.", "3.0", "3.14e+2" (decimal),
355             # "0b1.101p+2" (binary), "03.14p+2" and "0o3.14p+2" (octal), and
356             # "0x3.14p+2" (hexadecimal).
357              
358             float => sub {
359             #printf "# Value '%s' handled by the 'float' sub.\n", $_[0];
360 10     10   5929 _float_constant(shift);
361             },
362              
363             # Take care of each number written as an integer (no decimal point or
364             # exponent) using binary, octal, or hexadecimal notation, e.g., "0b101"
365             # (binary), "0314" and "0o314" (octal), and "0x314" (hexadecimal).
366              
367             binary => sub {
368             #printf "# Value '%s' handled by the 'binary' sub.\n", $_[0];
369 10     10   9303 my $str = shift;
370 10 100       67 return $obj_class -> new($str) if $str =~ /^0[XxBb]/;
371 3         11 $obj_class -> from_oct($str);
372 37         298 };
373             }
374              
375 11     11 1 7670 sub inf () { $obj_class -> binf(); }
376 10     10 1 8998 sub NaN () { $obj_class -> bnan(); }
377              
378             # This should depend on the current accuracy/precision. Fixme!
379 1     1 1 1371 sub PI () { $obj_class -> new('3.141592653589793238462643383279502884197'); }
380 1     1 1 67 sub e () { $obj_class -> new('2.718281828459045235360287471352662497757'); }
381              
382             sub bpi ($) {
383 1     1 1 5 my $up = Math::BigFloat -> upgrade(); # get current upgrading, if any ...
384 1         11 Math::BigFloat -> upgrade(undef); # ... and disable
385              
386 1         10 my $x = Math::BigFloat -> bpi(@_);
387              
388 1         768 Math::BigFloat -> upgrade($up); # reset the upgrading
389              
390 1         10 return $x;
391             }
392              
393             sub bexp ($$) {
394 1     1 1 918 my $up = Math::BigFloat -> upgrade(); # get current upgrading, if any ...
395 1         14 Math::BigFloat -> upgrade(undef); # ... and disable
396              
397 1         10 my $x = Math::BigFloat -> new(shift);
398 1         69 $x -> bexp(@_);
399              
400 1         1112 Math::BigFloat -> upgrade($up); # reset the upgrading
401              
402 1         10 return $x;
403             }
404              
405             1;
406              
407             __END__