File Coverage

blib/lib/bignum.pm
Criterion Covered Total %
statement 148 188 78.7
branch 47 84 55.9
condition 3 20 15.0
subroutine 29 33 87.8
pod 15 15 100.0
total 242 340 71.1


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