File Coverage

blib/lib/bigint.pm
Criterion Covered Total %
statement 129 160 80.6
branch 45 76 59.2
condition 4 20 20.0
subroutine 30 31 96.7
pod 13 13 100.0
total 221 300 73.6


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