File Coverage

blib/lib/Math/BigRat.pm
Criterion Covered Total %
statement 858 1060 80.9
branch 555 834 66.5
condition 235 411 57.1
subroutine 97 129 75.1
pod 70 71 98.5
total 1815 2505 72.4


line stmt bran cond sub pod time code
1             #
2             # "Tax the rat farms." - Lord Vetinari
3             #
4              
5             # The following hash values are used:
6             # sign : +,-,NaN,+inf,-inf
7             # _d : denominator
8             # _n : numerator (value = _n/_d)
9             # _a : accuracy
10             # _p : precision
11             # You should not look at the innards of a BigRat - use the methods for this.
12              
13             package Math::BigRat;
14              
15 19     19   1145405 use 5.006;
  19         179  
16 19     19   84 use strict;
  19         29  
  19         828  
17 19     19   96 use warnings;
  19         35  
  19         563  
18              
19 19     19   87 use Carp qw< carp croak >;
  19         38  
  19         995  
20 19     19   109 use Scalar::Util qw< blessed >;
  19         36  
  19         748  
21              
22 19     19   17814 use Math::BigFloat ();
  19         1003750  
  19         24297  
23              
24             our $VERSION = '0.2624';
25              
26             our @ISA = qw(Math::BigFloat);
27              
28             our ($accuracy, $precision, $round_mode, $div_scale,
29             $upgrade, $downgrade, $_trap_nan, $_trap_inf);
30              
31             use overload
32              
33             # overload key: with_assign
34              
35 49     49   282 '+' => sub { $_[0] -> copy() -> badd($_[1]); },
36              
37 53     53   289 '-' => sub { my $c = $_[0] -> copy;
38 53 50       135 $_[2] ? $c -> bneg() -> badd( $_[1])
39             : $c -> bsub($_[1]); },
40              
41 55     55   455 '*' => sub { $_[0] -> copy() -> bmul($_[1]); },
42              
43 49 50   49   765 '/' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bdiv($_[0])
44             : $_[0] -> copy() -> bdiv($_[1]); },
45              
46 21 50   21   146 '%' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bmod($_[0])
47             : $_[0] -> copy() -> bmod($_[1]); },
48              
49 2 50   2   11 '**' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bpow($_[0])
50             : $_[0] -> copy() -> bpow($_[1]); },
51              
52 0 0   0   0 '<<' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> blsft($_[0])
53             : $_[0] -> copy() -> blsft($_[1]); },
54              
55 0 0   0   0 '>>' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> brsft($_[0])
56             : $_[0] -> copy() -> brsft($_[1]); },
57              
58             # overload key: assign
59              
60 0     0   0 '+=' => sub { $_[0]->badd($_[1]); },
61              
62 1     1   540 '-=' => sub { $_[0]->bsub($_[1]); },
63              
64 1     1   10 '*=' => sub { $_[0]->bmul($_[1]); },
65              
66 0     0   0 '/=' => sub { scalar $_[0]->bdiv($_[1]); },
67              
68 0     0   0 '%=' => sub { $_[0]->bmod($_[1]); },
69              
70 0     0   0 '**=' => sub { $_[0]->bpow($_[1]); },
71              
72 0     0   0 '<<=' => sub { $_[0]->blsft($_[1]); },
73              
74 0     0   0 '>>=' => sub { $_[0]->brsft($_[1]); },
75              
76             # 'x=' => sub { },
77              
78             # '.=' => sub { },
79              
80             # overload key: num_comparison
81              
82 19 50   19   109 '<' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> blt($_[0])
83             : $_[0] -> blt($_[1]); },
84              
85 0 0   0   0 '<=' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> ble($_[0])
86             : $_[0] -> ble($_[1]); },
87              
88 24 50   24   189 '>' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bgt($_[0])
89             : $_[0] -> bgt($_[1]); },
90              
91 0 0   0   0 '>=' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bge($_[0])
92             : $_[0] -> bge($_[1]); },
93              
94 10     10   221 '==' => sub { $_[0] -> beq($_[1]); },
95              
96 0     0   0 '!=' => sub { $_[0] -> bne($_[1]); },
97              
98             # overload key: 3way_comparison
99              
100 0     0   0 '<=>' => sub { my $cmp = $_[0] -> bcmp($_[1]);
101 0 0 0     0 defined($cmp) && $_[2] ? -$cmp : $cmp; },
102              
103 1791 50   1791   507684 'cmp' => sub { $_[2] ? "$_[1]" cmp $_[0] -> bstr()
104             : $_[0] -> bstr() cmp "$_[1]"; },
105              
106             # overload key: str_comparison
107              
108             # 'lt' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bstrlt($_[0])
109             # : $_[0] -> bstrlt($_[1]); },
110             #
111             # 'le' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bstrle($_[0])
112             # : $_[0] -> bstrle($_[1]); },
113             #
114             # 'gt' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bstrgt($_[0])
115             # : $_[0] -> bstrgt($_[1]); },
116             #
117             # 'ge' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bstrge($_[0])
118             # : $_[0] -> bstrge($_[1]); },
119             #
120             # 'eq' => sub { $_[0] -> bstreq($_[1]); },
121             #
122             # 'ne' => sub { $_[0] -> bstrne($_[1]); },
123              
124             # overload key: binary
125              
126 289 50   289   21326 '&' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> band($_[0])
127             : $_[0] -> copy() -> band($_[1]); },
128              
129 0     0   0 '&=' => sub { $_[0] -> band($_[1]); },
130              
131 289 50   289   23236 '|' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bior($_[0])
132             : $_[0] -> copy() -> bior($_[1]); },
133              
134 0     0   0 '|=' => sub { $_[0] -> bior($_[1]); },
135              
136 289 50   289   21418 '^' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> bxor($_[0])
137             : $_[0] -> copy() -> bxor($_[1]); },
138              
139 0     0   0 '^=' => sub { $_[0] -> bxor($_[1]); },
140              
141             # '&.' => sub { },
142              
143             # '&.=' => sub { },
144              
145             # '|.' => sub { },
146              
147             # '|.=' => sub { },
148              
149             # '^.' => sub { },
150              
151             # '^.=' => sub { },
152              
153             # overload key: unary
154              
155 0     0   0 'neg' => sub { $_[0] -> copy() -> bneg(); },
156              
157             # '!' => sub { },
158              
159 0     0   0 '~' => sub { $_[0] -> copy() -> bnot(); },
160              
161             # '~.' => sub { },
162              
163             # overload key: mutators
164              
165 6     6   56 '++' => sub { $_[0] -> binc() },
166              
167 5     5   47 '--' => sub { $_[0] -> bdec() },
168              
169             # overload key: func
170              
171 0 0   0   0 'atan2' => sub { $_[2] ? ref($_[0]) -> new($_[1]) -> batan2($_[0])
172             : $_[0] -> copy() -> batan2($_[1]); },
173              
174 0     0   0 'cos' => sub { $_[0] -> copy() -> bcos(); },
175              
176 0     0   0 'sin' => sub { $_[0] -> copy() -> bsin(); },
177              
178 0     0   0 'exp' => sub { $_[0] -> copy() -> bexp($_[1]); },
179              
180 0     0   0 'abs' => sub { $_[0] -> copy() -> babs(); },
181              
182 7     7   49 'log' => sub { $_[0] -> copy() -> blog(); },
183              
184 0     0   0 'sqrt' => sub { $_[0] -> copy() -> bsqrt(); },
185              
186 2     2   17 'int' => sub { $_[0] -> copy() -> bint(); },
187              
188             # overload key: conversion
189              
190 0 0   0   0 'bool' => sub { $_[0] -> is_zero() ? '' : 1; },
191              
192 5248     5248   298694 '""' => sub { $_[0] -> bstr(); },
193              
194 8     8   52 '0+' => sub { $_[0] -> numify(); },
195              
196 0     0   0 '=' => sub { $_[0]->copy(); },
197              
198 19     19   204 ;
  19         58  
  19         1283  
199              
200             BEGIN {
201 19     19   9120 *objectify = \&Math::BigInt::objectify; # inherit this from BigInt
202 19         56 *AUTOLOAD = \&Math::BigFloat::AUTOLOAD; # can't inherit AUTOLOAD
203 19         55 *as_number = \&as_int;
204 19         48 *is_pos = \&is_positive;
205 19         218379 *is_neg = \&is_negative;
206             }
207              
208             ##############################################################################
209             # Global constants and flags. Access these only via the accessor methods!
210              
211             $accuracy = $precision = undef;
212             $round_mode = 'even';
213             $div_scale = 40;
214             $upgrade = undef;
215             $downgrade = undef;
216              
217             # These are internally, and not to be used from the outside at all!
218              
219             $_trap_nan = 0; # are NaNs ok? set w/ config()
220             $_trap_inf = 0; # are infs ok? set w/ config()
221              
222             # the math backend library
223              
224             my $LIB = 'Math::BigInt::Calc';
225              
226             my $nan = 'NaN';
227             #my $class = 'Math::BigRat';
228              
229             sub isa {
230 6309 100   6309 0 621961 return 0 if $_[1] =~ /^Math::Big(Int|Float)/; # we aren't
231 3530         12110 UNIVERSAL::isa(@_);
232             }
233              
234             ##############################################################################
235              
236             sub new {
237 19671     19671 1 14351838 my $proto = shift;
238 19671         29998 my $protoref = ref $proto;
239 19671   33     69729 my $class = $protoref || $proto;
240              
241             # Check the way we are called.
242              
243 19671 50       38690 if ($protoref) {
244 0         0 croak("new() is a class method, not an instance method");
245             }
246              
247 19671 100       39792 if (@_ < 1) {
248             #carp("Using new() with no argument is deprecated;",
249             # " use bzero() or new(0) instead");
250 1         3 return $class -> bzero();
251             }
252              
253 19670 50       37958 if (@_ > 2) {
254 0         0 carp("Superfluous arguments to new() ignored.");
255             }
256              
257             # Get numerator and denominator. If any of the arguments is undefined,
258             # return zero.
259              
260 19670         34736 my ($n, $d) = @_;
261              
262 19670 100 100     83292 if (@_ == 1 && !defined $n ||
      33        
      66        
      66        
263             @_ == 2 && (!defined $n || !defined $d))
264             {
265             #carp("Use of uninitialized value in new()");
266 1         3 return $class -> bzero();
267             }
268              
269             # Initialize a new object.
270              
271 19669         35697 my $self = bless {}, $class;
272              
273             # One or two input arguments may be given. First handle the numerator $n.
274              
275 19669 100       37457 if (ref($n)) {
276 5828 50 66     37137 $n = Math::BigFloat -> new($n, undef, undef)
      66        
277             unless ($n -> isa('Math::BigRat') ||
278             $n -> isa('Math::BigInt') ||
279             $n -> isa('Math::BigFloat'));
280             } else {
281 13841 100       22431 if (defined $d) {
282             # If the denominator is defined, the numerator is not a string
283             # fraction, e.g., "355/113".
284 5         12 $n = Math::BigFloat -> new($n, undef, undef);
285             } else {
286             # If the denominator is undefined, the numerator might be a string
287             # fraction, e.g., "355/113".
288 13836 100       25498 if ($n =~ m| ^ \s* (\S+) \s* / \s* (\S+) \s* $ |x) {
289 397         1755 $n = Math::BigFloat -> new($1, undef, undef);
290 397         22834 $d = Math::BigFloat -> new($2, undef, undef);
291             } else {
292 13439         40650 $n = Math::BigFloat -> new($n, undef, undef);
293             }
294             }
295             }
296              
297             # At this point $n is an object and $d is either an object or undefined. An
298             # undefined $d means that $d was not specified by the caller (not that $d
299             # was specified as an undefined value).
300              
301 19669 100       884027 unless (defined $d) {
302             #return $n -> copy($n) if $n -> isa('Math::BigRat');
303 19262 50       47208 if ($n -> isa('Math::BigRat')) {
304 0 0 0     0 return $downgrade -> new($n)
305             if defined($downgrade) && $n -> is_int();
306 0         0 return $class -> copy($n);
307             }
308              
309 19262 100       141089 if ($n -> is_nan()) {
310 333         2381 return $class -> bnan();
311             }
312              
313 18929 100       123070 if ($n -> is_inf()) {
314 563         5574 return $class -> binf($n -> sign());
315             }
316              
317 18366 100       130890 if ($n -> isa('Math::BigInt')) {
318 5717         16479 $self -> {_n} = $LIB -> _new($n -> copy() -> babs(undef, undef)
319             -> bstr());
320 5717         336682 $self -> {_d} = $LIB -> _one();
321 5717         29714 $self -> {sign} = $n -> sign();
322 5717 100       40439 return $downgrade -> new($n) if defined $downgrade;
323 5716         11274 return $self;
324             }
325              
326 12649 50       75557 if ($n -> isa('Math::BigFloat')) {
327 12649         92368 my $m = $n -> mantissa(undef, undef) -> babs(undef, undef);
328 12649         1239347 my $e = $n -> exponent(undef, undef);
329 12649         1189988 $self -> {_n} = $LIB -> _new($m -> bstr());
330 12649         297032 $self -> {_d} = $LIB -> _one();
331              
332 12649 100       72094 if ($e > 0) {
    100          
333             $self -> {_n} = $LIB -> _lsft($self -> {_n},
334 747         127537 $LIB -> _new($e -> bstr()), 10);
335             } elsif ($e < 0) {
336             $self -> {_d} = $LIB -> _lsft($self -> {_d},
337 880         249603 $LIB -> _new(-$e -> bstr()), 10);
338              
339             my $gcd = $LIB -> _gcd($LIB -> _copy($self -> {_n}),
340 880         85617 $self -> {_d});
341 880 100       86348 if (!$LIB -> _is_one($gcd)) {
342 852         4811 $self -> {_n} = $LIB -> _div($self->{_n}, $gcd);
343 852         7444 $self -> {_d} = $LIB -> _div($self->{_d}, $gcd);
344             }
345             }
346              
347 12649         3469098 $self -> {sign} = $n -> sign();
348 12649 100 100     97173 return $downgrade -> new($n, undef, undef)
349             if defined($downgrade) && $n -> is_int();
350 12644         143194 return $self;
351             }
352              
353 0         0 die "I don't know how to handle this"; # should never get here
354             }
355              
356             # At the point we know that both $n and $d are defined. We know that $n is
357             # an object, but $d might still be a scalar. Now handle $d.
358              
359 407 100 66     1963 $d = Math::BigFloat -> new($d, undef, undef)
      100        
360             unless ref($d) && ($d -> isa('Math::BigRat') ||
361             $d -> isa('Math::BigInt') ||
362             $d -> isa('Math::BigFloat'));
363              
364             # At this point both $n and $d are objects.
365              
366 407 100 66     9482 if ($n -> is_nan() || $d -> is_nan()) {
367 3         23 return $class -> bnan();
368             }
369              
370             # At this point neither $n nor $d is a NaN.
371              
372 404 100       5174 if ($n -> is_zero()) {
373 6 50       67 if ($d -> is_zero()) { # 0/0 = NaN
374 0         0 return $class -> bnan();
375             }
376 6         61 return $class -> bzero();
377             }
378              
379 398 50       4570 if ($d -> is_zero()) {
380 0         0 return $class -> binf($d -> sign());
381             }
382              
383             # At this point, neither $n nor $d is a NaN or a zero.
384              
385             # Copy them now before manipulating them.
386              
387 398         4291 $n = $n -> copy();
388 398         12563 $d = $d -> copy();
389              
390 398 100       9696 if ($d < 0) { # make sure denominator is positive
391 10         1592 $n -> bneg();
392 10         381 $d -> bneg();
393             }
394              
395 398 100       78010 if ($n -> is_inf()) {
396 8 100       67 return $class -> bnan() if $d -> is_inf(); # Inf/Inf = NaN
397 7         47 return $class -> binf($n -> sign());
398             }
399              
400             # At this point $n is finite.
401              
402 390 100       3281 return $class -> bzero() if $d -> is_inf();
403 386 50       2512 return $class -> binf($d -> sign()) if $d -> is_zero();
404              
405             # At this point both $n and $d are finite and non-zero.
406              
407 386 100       3460 if ($n < 0) {
408 129         19421 $n -> bneg();
409 129         5194 $self -> {sign} = '-';
410             } else {
411 257         42443 $self -> {sign} = '+';
412             }
413              
414 386 50       1044 if ($n -> isa('Math::BigRat')) {
415              
416 0 0       0 if ($d -> isa('Math::BigRat')) {
417              
418             # At this point both $n and $d is a Math::BigRat.
419              
420             # p r p * s (p / gcd(p, r)) * (s / gcd(s, q))
421             # - / - = ----- = ---------------------------------
422             # q s q * r (q / gcd(s, q)) * (r / gcd(p, r))
423              
424 0         0 my $p = $n -> {_n};
425 0         0 my $q = $n -> {_d};
426 0         0 my $r = $d -> {_n};
427 0         0 my $s = $d -> {_d};
428 0         0 my $gcd_pr = $LIB -> _gcd($LIB -> _copy($p), $r);
429 0         0 my $gcd_sq = $LIB -> _gcd($LIB -> _copy($s), $q);
430 0         0 $self -> {_n} = $LIB -> _mul($LIB -> _div($LIB -> _copy($p), $gcd_pr),
431             $LIB -> _div($LIB -> _copy($s), $gcd_sq));
432 0         0 $self -> {_d} = $LIB -> _mul($LIB -> _div($LIB -> _copy($q), $gcd_sq),
433             $LIB -> _div($LIB -> _copy($r), $gcd_pr));
434              
435 0 0 0     0 return $downgrade -> new($n->bstr())
436             if defined($downgrade) && $self -> is_int();
437 0         0 return $self; # no need for $self -> bnorm() here
438             }
439              
440             # At this point, $n is a Math::BigRat and $d is a Math::Big(Int|Float).
441              
442 0         0 my $p = $n -> {_n};
443 0         0 my $q = $n -> {_d};
444 0         0 my $m = $d -> mantissa();
445 0         0 my $e = $d -> exponent();
446              
447             # / p
448             # | ------------ if e > 0
449             # | q * m * 10^e
450             # |
451             # p | p
452             # - / (m * 10^e) = | ----- if e == 0
453             # q | q * m
454             # |
455             # | p * 10^-e
456             # | -------- if e < 0
457             # \ q * m
458              
459 0         0 $self -> {_n} = $LIB -> _copy($p);
460 0         0 $self -> {_d} = $LIB -> _mul($LIB -> _copy($q), $m);
461 0 0       0 if ($e > 0) {
    0          
462 0         0 $self -> {_d} = $LIB -> _lsft($self -> {_d}, $e, 10);
463             } elsif ($e < 0) {
464 0         0 $self -> {_n} = $LIB -> _lsft($self -> {_n}, -$e, 10);
465             }
466              
467 0         0 return $self -> bnorm();
468              
469             } else {
470              
471 386 50       3338 if ($d -> isa('Math::BigRat')) {
472              
473             # At this point $n is a Math::Big(Int|Float) and $d is a
474             # Math::BigRat.
475              
476 0         0 my $m = $n -> mantissa();
477 0         0 my $e = $n -> exponent();
478 0         0 my $p = $d -> {_n};
479 0         0 my $q = $d -> {_d};
480              
481             # / q * m * 10^e
482             # | ------------ if e > 0
483             # | p
484             # |
485             # p | m * q
486             # (m * 10^e) / - = | ----- if e == 0
487             # q | p
488             # |
489             # | q * m
490             # | --------- if e < 0
491             # \ p * 10^-e
492              
493 0         0 $self -> {_n} = $LIB -> _mul($LIB -> _copy($q), $m);
494 0         0 $self -> {_d} = $LIB -> _copy($p);
495 0 0       0 if ($e > 0) {
    0          
496 0         0 $self -> {_n} = $LIB -> _lsft($self -> {_n}, $e, 10);
497             } elsif ($e < 0) {
498 0         0 $self -> {_d} = $LIB -> _lsft($self -> {_d}, -$e, 10);
499             }
500 0         0 return $self -> bnorm();
501              
502             } else {
503              
504             # At this point $n and $d are both a Math::Big(Int|Float)
505              
506 386         3156 my $m1 = $n -> mantissa();
507 386         27251 my $e1 = $n -> exponent();
508 386         36561 my $m2 = $d -> mantissa();
509 386         21414 my $e2 = $d -> exponent();
510              
511             # /
512             # | m1 * 10^(e1 - e2)
513             # | ----------------- if e1 > e2
514             # | m2
515             # |
516             # m1 * 10^e1 | m1
517             # ---------- = | -- if e1 = e2
518             # m2 * 10^e2 | m2
519             # |
520             # | m1
521             # | ----------------- if e1 < e2
522             # | m2 * 10^(e2 - e1)
523             # \
524              
525 386         32719 $self -> {_n} = $LIB -> _new($m1 -> bstr());
526 386         9976 $self -> {_d} = $LIB -> _new($m2 -> bstr());
527 386         8345 my $ediff = $e1 - $e2;
528 386 100       30690 if ($ediff > 0) {
    100          
529             $self -> {_n} = $LIB -> _lsft($self -> {_n},
530 24         3971 $LIB -> _new($ediff -> bstr()),
531             10);
532             } elsif ($ediff < 0) {
533             $self -> {_d} = $LIB -> _lsft($self -> {_d},
534 22         6357 $LIB -> _new(-$ediff -> bstr()),
535             10);
536             }
537              
538 386         109934 return $self -> bnorm();
539             }
540             }
541              
542 0 0 0     0 return $downgrade -> new($self -> bstr())
543             if defined($downgrade) && $self -> is_int();
544 0         0 return $self;
545             }
546              
547             sub copy {
548 1319     1319 1 65696 my $self = shift;
549 1319         2060 my $selfref = ref $self;
550 1319   33     2568 my $class = $selfref || $self;
551              
552             # If called as a class method, the object to copy is the next argument.
553              
554 1319 50       3341 $self = shift() unless $selfref;
555              
556 1319         2423 my $copy = bless {}, $class;
557              
558 1319         2764 $copy->{sign} = $self->{sign};
559 1319         3419 $copy->{_d} = $LIB->_copy($self->{_d});
560 1319         8395 $copy->{_n} = $LIB->_copy($self->{_n});
561 1319 50       7211 $copy->{_a} = $self->{_a} if defined $self->{_a};
562 1319 50       2211 $copy->{_p} = $self->{_p} if defined $self->{_p};
563              
564             #($copy, $copy->{_a}, $copy->{_p})
565             # = $copy->_find_round_parameters(@_);
566              
567 1319         3548 return $copy;
568             }
569              
570             sub bnan {
571 537     537 1 2681 my $self = shift;
572 537         900 my $selfref = ref $self;
573 537   66     1450 my $class = $selfref || $self;
574              
575 537 100       1160 $self = bless {}, $class unless $selfref;
576              
577 537 100       1150 if ($_trap_nan) {
578 5         562 croak ("Tried to set a variable to NaN in $class->bnan()");
579             }
580              
581 532 100       1049 return $downgrade -> bnan() if defined $downgrade;
582              
583 525         1197 $self -> {sign} = $nan;
584 525         1090 $self -> {_n} = $LIB -> _zero();
585 525         2718 $self -> {_d} = $LIB -> _one();
586              
587             ($self, $self->{_a}, $self->{_p})
588 525         2913 = $self->_find_round_parameters(@_);
589              
590 525         17378 return $self;
591             }
592              
593             sub binf {
594 751     751 1 6119 my $self = shift;
595 751         1177 my $selfref = ref $self;
596 751   66     2186 my $class = $selfref || $self;
597              
598 751 100       1827 $self = bless {}, $class unless $selfref;
599              
600 751         1150 my $sign = shift();
601 751 100 100     3062 $sign = defined($sign) && substr($sign, 0, 1) eq '-' ? '-inf' : '+inf';
602              
603 751 100       1591 if ($_trap_inf) {
604 12         1161 croak ("Tried to set a variable to +-inf in $class->binf()");
605             }
606              
607 739 100       1394 return $downgrade -> binf($sign) if defined $downgrade;
608              
609 732         1327 $self -> {sign} = $sign;
610 732         1671 $self -> {_n} = $LIB -> _zero();
611 732         3855 $self -> {_d} = $LIB -> _one();
612              
613             ($self, $self->{_a}, $self->{_p})
614 732         4069 = $self->_find_round_parameters(@_);
615              
616 732         25629 return $self;
617             }
618              
619             sub bone {
620 13     13 1 1233 my $self = shift;
621 13         26 my $selfref = ref $self;
622 13   66     32 my $class = $selfref || $self;
623              
624 13         20 my $sign = shift();
625 13 100 100     64 $sign = '+' unless defined($sign) && $sign eq '-';
626              
627 13 100       36 return $downgrade -> bone($sign) if defined $downgrade;
628              
629 12 50       23 $self = bless {}, $class unless $selfref;
630 12         22 $self -> {sign} = $sign;
631 12         28 $self -> {_n} = $LIB -> _one();
632 12         64 $self -> {_d} = $LIB -> _one();
633              
634             ($self, $self->{_a}, $self->{_p})
635 12         63 = $self->_find_round_parameters(@_);
636              
637 12         478 return $self;
638             }
639              
640             sub bzero {
641 62     62 1 1733 my $self = shift;
642 62         112 my $selfref = ref $self;
643 62   66     221 my $class = $selfref || $self;
644              
645 62 100       155 return $downgrade -> bzero() if defined $downgrade;
646              
647 61 100       164 $self = bless {}, $class unless $selfref;
648 61         124 $self -> {sign} = '+';
649 61         154 $self -> {_n} = $LIB -> _zero();
650 61         348 $self -> {_d} = $LIB -> _one();
651              
652             ($self, $self->{_a}, $self->{_p})
653 61         362 = $self->_find_round_parameters(@_);
654              
655 61         2000 return $self;
656             }
657              
658             ##############################################################################
659              
660             sub config {
661             # return (later set?) configuration data as hash ref
662 12   50 12 1 3332 my $class = shift() || 'Math::BigRat';
663              
664 12 100 100     42 if (@_ == 1 && ref($_[0]) ne 'HASH') {
665 6         14 my $cfg = $class->SUPER::config();
666 6         264 return $cfg->{$_[0]};
667             }
668              
669 6         24 my $cfg = $class->SUPER::config(@_);
670              
671             # now we need only to override the ones that are different from our parent
672 6         501 $cfg->{class} = $class;
673 6         12 $cfg->{with} = $LIB;
674              
675 6         17 $cfg;
676             }
677              
678             ###############################################################################
679             # String conversion methods
680             ###############################################################################
681              
682             sub bstr {
683 29743 50   29743 1 12000982 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_);
684              
685 29743 50       63527 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r;
686              
687             # Inf and NaN
688              
689 29743 100 100     86592 if ($x->{sign} ne '+' && $x->{sign} ne '-') {
690 1200 100       7202 return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN
691 351         1985 return 'inf'; # +inf
692             }
693              
694             # Upgrade?
695              
696 28543 50 33     62930 return $upgrade -> bstr($x, @r)
697             if defined($upgrade) && !$x -> isa($class);
698              
699             # Finite number
700              
701 28543         35703 my $s = '';
702 28543 100       52924 $s = $x->{sign} if $x->{sign} ne '+'; # '+3/2' => '3/2'
703              
704 28543 100       55239 my $str = $x->{sign} eq '-' ? '-' : '';
705 28543         74412 $str .= $LIB->_str($x->{_n});
706 28543 100       277142 $str .= '/' . $LIB->_str($x->{_d}) unless $LIB -> _is_one($x->{_d});
707 28543         236551 return $str;
708             }
709              
710             sub bsstr {
711 8 50   8 1 60 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_);
712              
713 8 50       20 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r;
714              
715             # Inf and NaN
716              
717 8 100 100     31 if ($x->{sign} ne '+' && $x->{sign} ne '-') {
718 3 100       21 return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN
719 1         8 return 'inf'; # +inf
720             }
721              
722             # Upgrade?
723              
724 5 50 33     28 return $upgrade -> bsstr($x, @r)
725             if defined($upgrade) && !$x -> isa($class);
726              
727             # Finite number
728              
729 5 100       14 my $str = $x->{sign} eq '-' ? '-' : '';
730 5         14 $str .= $LIB->_str($x->{_n});
731 5 100       53 $str .= '/' . $LIB->_str($x->{_d}) unless $LIB -> _is_one($x->{_d});
732 5         73 return $str;
733             }
734              
735             sub bfstr {
736 0 0   0 1 0 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_);
737              
738 0 0       0 carp "Rounding is not supported for ", (caller(0))[3], "()" if @r;
739              
740             # Inf and NaN
741              
742 0 0 0     0 if ($x->{sign} ne '+' && $x->{sign} ne '-') {
743 0 0       0 return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN
744 0         0 return 'inf'; # +inf
745             }
746              
747             # Upgrade?
748              
749 0 0 0     0 return $upgrade -> bfstr($x, @r)
750             if defined($upgrade) && !$x -> isa($class);
751              
752             # Finite number
753              
754 0 0       0 my $str = $x->{sign} eq '-' ? '-' : '';
755 0         0 $str .= $LIB->_str($x->{_n});
756 0 0       0 $str .= '/' . $LIB->_str($x->{_d}) unless $LIB -> _is_one($x->{_d});
757 0         0 return $str;
758             }
759              
760             sub bnorm {
761             # reduce the number to the shortest form
762 769 100   769 1 11865 my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_);
763              
764             # Both parts must be objects of whatever we are using today.
765 769 50       2587 if (my $c = $LIB->_check($x->{_n})) {
766 0         0 croak("n did not pass the self-check ($c) in bnorm()");
767             }
768 769 50       26875 if (my $c = $LIB->_check($x->{_d})) {
769 0         0 croak("d did not pass the self-check ($c) in bnorm()");
770             }
771              
772             # no normalize for NaN, inf etc.
773 769 100       19614 if ($x->{sign} !~ /^[+-]$/) {
774 18 100       51 return $downgrade -> new($x) if defined $downgrade;
775 16         116 return $x;
776             }
777              
778             # normalize zeros to 0/1
779 751 100       1822 if ($LIB->_is_zero($x->{_n})) {
780 36 100       193 return $downgrade -> bzero() if defined($downgrade);
781 33         47 $x->{sign} = '+'; # never leave a -0
782 33 100       67 $x->{_d} = $LIB->_one() unless $LIB->_is_one($x->{_d});
783 33         249 return $x;
784             }
785              
786             # n/1
787 715 100       4425 if ($LIB->_is_one($x->{_d})) {
788 216 100       1179 return $downgrade -> new($x) if defined($downgrade);
789 205         1802 return $x; # no need to reduce
790             }
791              
792             # Compute the GCD.
793 499         3183 my $gcd = $LIB->_gcd($LIB->_copy($x->{_n}), $x->{_d});
794 499 100       30267 if (!$LIB->_is_one($gcd)) {
795 97         707 $x->{_n} = $LIB->_div($x->{_n}, $gcd);
796 97         1354 $x->{_d} = $LIB->_div($x->{_d}, $gcd);
797             }
798              
799 499         9033 $x;
800             }
801              
802             ##############################################################################
803             # sign manipulation
804              
805             sub bneg {
806             # (BRAT or num_str) return BRAT
807             # negate number or make a negated number from string
808 26 50   26 1 121 my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_);
809              
810 26 50       99 return $x if $x->modify('bneg');
811              
812             # for +0 do not negate (to have always normalized +0). Does nothing for 'NaN'
813             $x->{sign} =~ tr/+-/-+/
814 26 100 100     161 unless ($x->{sign} eq '+' && $LIB->_is_zero($x->{_n}));
815              
816             return $downgrade -> new($x)
817 26 100 100     137 if defined($downgrade) && $LIB -> _is_one($x->{_d});
818 22         257 $x;
819             }
820              
821             ##############################################################################
822             # mul/add/div etc
823              
824             sub badd {
825             # add two rational numbers
826              
827             # set up parameters
828 325     325 1 1709 my ($class, $x, $y, @r) = (ref($_[0]), @_);
829             # objectify is costly, so avoid it
830 325 100 66     1278 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) {
831 91         291 ($class, $x, $y, @r) = objectify(2, @_);
832             }
833              
834 325 100 100     1450 unless ($x -> is_finite() && $y -> is_finite()) {
835 202 100 100     1793 if ($x -> is_nan() || $y -> is_nan()) {
    100          
    100          
    100          
    50          
836 62         521 return $x -> bnan(@r);
837             } elsif ($x -> is_inf("+")) {
838 41 100       1804 return $x -> bnan(@r) if $y -> is_inf("-");
839 35         670 return $x -> binf("+", @r);
840             } elsif ($x -> is_inf("-")) {
841 41 100       1865 return $x -> bnan(@r) if $y -> is_inf("+");
842 35         632 return $x -> binf("-", @r);
843             } elsif ($y -> is_inf("+")) {
844 30         1747 return $x -> binf("+", @r);
845             } elsif ($y -> is_inf("-")) {
846 28         2177 return $x -> binf("-", @r);
847             }
848             }
849              
850             # 1 1 gcd(3, 4) = 1 1*3 + 1*4 7
851             # - + - = --------- = --
852             # 4 3 4*3 12
853              
854             # we do not compute the gcd() here, but simple do:
855             # 5 7 5*3 + 7*4 43
856             # - + - = --------- = --
857             # 4 3 4*3 12
858              
859             # and bnorm() will then take care of the rest
860              
861             # 5 * 3
862 123         1431 $x->{_n} = $LIB->_mul($x->{_n}, $y->{_d});
863              
864             # 7 * 4
865 123         1231 my $m = $LIB->_mul($LIB->_copy($y->{_n}), $x->{_d});
866              
867             # 5 * 3 + 7 * 4
868 123         1519 ($x->{_n}, $x->{sign}) = $LIB -> _sadd($x->{_n}, $x->{sign}, $m, $y->{sign});
869              
870             # 4 * 3
871 123         3946 $x->{_d} = $LIB->_mul($x->{_d}, $y->{_d});
872              
873             # normalize result, and possible round
874 123         959 $x->bnorm()->round(@r);
875             }
876              
877             sub bsub {
878             # subtract two rational numbers
879              
880             # set up parameters
881 91     91 1 435 my ($class, $x, $y, @r) = (ref($_[0]), @_);
882             # objectify is costly, so avoid it
883 91 100 66     344 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) {
884 5         16 ($class, $x, $y, @r) = objectify(2, @_);
885             }
886              
887             # flip sign of $x, call badd(), then flip sign of result
888             $x->{sign} =~ tr/+-/-+/
889 91 100 100     317 unless $x->{sign} eq '+' && $x -> is_zero(); # not -0
890 91         259 $x = $x->badd($y, @r); # does norm and round
891             $x->{sign} =~ tr/+-/-+/
892 91 100 100     710 unless $x->{sign} eq '+' && $x -> is_zero(); # not -0
893              
894 91         277 $x->bnorm();
895             }
896              
897             sub bmul {
898             # multiply two rational numbers
899              
900             # set up parameters
901 93     93 1 475 my ($class, $x, $y, @r) = (ref($_[0]), @_);
902             # objectify is costly, so avoid it
903 93 100 66     412 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) {
904 6         19 ($class, $x, $y, @r) = objectify(2, @_);
905             }
906              
907 93 100 100     420 return $x->bnan() if $x->{sign} eq 'NaN' || $y->{sign} eq 'NaN';
908              
909             # inf handling
910 85 100 100     344 if ($x->{sign} =~ /^[+-]inf$/ || $y->{sign} =~ /^[+-]inf$/) {
911 13 50 33     30 return $x->bnan() if $x->is_zero() || $y->is_zero();
912             # result will always be +-inf:
913             # +inf * +/+inf => +inf, -inf * -/-inf => +inf
914             # +inf * -/-inf => -inf, -inf * +/+inf => -inf
915 13 100 100     59 return $x->binf() if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/);
916 8 100 100     38 return $x->binf() if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/);
917 6         12 return $x->binf('-');
918             }
919              
920             # x == 0 # also: or y == 1 or y == -1
921 72 100       246 if ($x -> is_zero()) {
922 5 100       45 $x = $downgrade -> bzero($x) if defined $downgrade;
923 5 50       129 return wantarray ? ($x, $class->bzero()) : $x;
924             }
925              
926 67 100       160 if ($y -> is_zero()) {
927 3 50       26 $x = defined($downgrade) ? $downgrade -> bzero($x) : $x -> bzero();
928 3 50       34 return wantarray ? ($x, $class->bzero()) : $x;
929             }
930              
931             # According to Knuth, this can be optimized by doing gcd twice (for d
932             # and n) and reducing in one step. This saves us a bnorm() at the end.
933             #
934             # p s p * s (p / gcd(p, r)) * (s / gcd(s, q))
935             # - * - = ----- = ---------------------------------
936             # q r q * r (q / gcd(s, q)) * (r / gcd(p, r))
937              
938 64         190 my $gcd_pr = $LIB -> _gcd($LIB -> _copy($x->{_n}), $y->{_d});
939 64         2559 my $gcd_sq = $LIB -> _gcd($LIB -> _copy($y->{_n}), $x->{_d});
940              
941             $x->{_n} = $LIB -> _mul(scalar $LIB -> _div($x->{_n}, $gcd_pr),
942 64         1866 scalar $LIB -> _div($LIB -> _copy($y->{_n}),
943             $gcd_sq));
944             $x->{_d} = $LIB -> _mul(scalar $LIB -> _div($x->{_d}, $gcd_sq),
945 64         2407 scalar $LIB -> _div($LIB -> _copy($y->{_d}),
946             $gcd_pr));
947              
948             # compute new sign
949 64 100       1561 $x->{sign} = $x->{sign} eq $y->{sign} ? '+' : '-';
950              
951 64         166 $x->bnorm()->round(@r);
952             }
953              
954             sub bdiv {
955             # (dividend: BRAT or num_str, divisor: BRAT or num_str) return
956             # (BRAT, BRAT) (quo, rem) or BRAT (only rem)
957              
958             # set up parameters
959 87     87 1 564 my ($class, $x, $y, @r) = (ref($_[0]), @_);
960             # objectify is costly, so avoid it
961 87 100 66     483 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) {
962 7         22 ($class, $x, $y, @r) = objectify(2, @_);
963             }
964              
965 87 50       369 return $x if $x->modify('bdiv');
966              
967 87         169 my $wantarray = wantarray; # call only once
968              
969             # At least one argument is NaN. This is handled the same way as in
970             # Math::BigInt -> bdiv(). See the comments in the code implementing that
971             # method.
972              
973 87 100 100     260 if ($x -> is_nan() || $y -> is_nan()) {
974 5 50       49 if ($wantarray) {
975 0 0       0 return $downgrade -> bnan(), $downgrade -> bnan()
976             if defined($downgrade);
977 0         0 return $x -> bnan(), $class -> bnan();
978             } else {
979 5 50       12 return $downgrade -> bnan()
980             if defined($downgrade);
981 5         15 return $x -> bnan();
982             }
983             }
984              
985             # Divide by zero and modulo zero. This is handled the same way as in
986             # Math::BigInt -> bdiv(). See the comments in the code implementing that
987             # method.
988              
989 82 100       1172 if ($y -> is_zero()) {
990 11         91 my ($quo, $rem);
991 11 100       31 if ($wantarray) {
992 3         13 $rem = $x -> copy();
993             }
994 11 100       25 if ($x -> is_zero()) {
995 3         25 $quo = $x -> bnan();
996             } else {
997 8         36 $quo = $x -> binf($x -> {sign});
998             }
999              
1000 8 50 33     43 $quo = $downgrade -> new($quo)
1001             if defined($downgrade) && $quo -> is_int();
1002 8 50 66     34 $rem = $downgrade -> new($rem)
      33        
1003             if $wantarray && defined($downgrade) && $rem -> is_int();
1004 8 100       102 return $wantarray ? ($quo, $rem) : $quo;
1005             }
1006              
1007             # Numerator (dividend) is +/-inf. This is handled the same way as in
1008             # Math::BigInt -> bdiv(). See the comments in the code implementing that
1009             # method.
1010              
1011 71 50       213 if ($x -> is_inf()) {
1012 0         0 my ($quo, $rem);
1013 0 0       0 $rem = $class -> bnan() if $wantarray;
1014 0 0       0 if ($y -> is_inf()) {
1015 0         0 $quo = $x -> bnan();
1016             } else {
1017 0 0       0 my $sign = $x -> bcmp(0) == $y -> bcmp(0) ? '+' : '-';
1018 0         0 $quo = $x -> binf($sign);
1019             }
1020              
1021 0 0 0     0 $quo = $downgrade -> new($quo)
1022             if defined($downgrade) && $quo -> is_int();
1023 0 0 0     0 $rem = $downgrade -> new($rem)
      0        
1024             if $wantarray && defined($downgrade) && $rem -> is_int();
1025 0 0       0 return $wantarray ? ($quo, $rem) : $quo;
1026             }
1027              
1028             # Denominator (divisor) is +/-inf. This is handled the same way as in
1029             # Math::BigFloat -> bdiv(). See the comments in the code implementing that
1030             # method.
1031              
1032 71 100       658 if ($y -> is_inf()) {
1033 2         18 my ($quo, $rem);
1034 2 50       6 if ($wantarray) {
1035 0 0 0     0 if ($x -> is_zero() || $x -> bcmp(0) == $y -> bcmp(0)) {
1036 0         0 $rem = $x -> copy();
1037 0         0 $quo = $x -> bzero();
1038             } else {
1039 0         0 $rem = $class -> binf($y -> {sign});
1040 0         0 $quo = $x -> bone('-');
1041             }
1042 0 0 0     0 $quo = $downgrade -> new($quo)
1043             if defined($downgrade) && $quo -> is_int();
1044 0 0 0     0 $rem = $downgrade -> new($rem)
1045             if defined($downgrade) && $rem -> is_int();
1046 0         0 return ($quo, $rem);
1047             } else {
1048 2 50       8 if ($y -> is_inf()) {
1049 2 50 33     18 if ($x -> is_nan() || $x -> is_inf()) {
1050 0 0       0 return $downgrade -> bnan() if defined $downgrade;
1051 0         0 return $x -> bnan();
1052             } else {
1053 2 50       27 return $downgrade -> bzero() if defined $downgrade;
1054 2         9 return $x -> bzero();
1055             }
1056             }
1057             }
1058             }
1059              
1060             # At this point, both the numerator and denominator are finite numbers, and
1061             # the denominator (divisor) is non-zero.
1062              
1063             # x == 0?
1064 69 100       491 if ($x->is_zero()) {
1065 3 0       30 return $wantarray ? ($downgrade -> bzero(), $downgrade -> bzero())
    50          
1066             : $downgrade -> bzero() if defined $downgrade;
1067 3 100       39 return $wantarray ? ($x, $class->bzero()) : $x;
1068             }
1069              
1070             # XXX TODO: list context, upgrade
1071             # According to Knuth, this can be optimized by doing gcd twice (for d and n)
1072             # and reducing in one step. This would save us the bnorm() at the end.
1073             #
1074             # p r p * s (p / gcd(p, r)) * (s / gcd(s, q))
1075             # - / - = ----- = ---------------------------------
1076             # q s q * r (q / gcd(s, q)) * (r / gcd(p, r))
1077              
1078 66         284 $x->{_n} = $LIB->_mul($x->{_n}, $y->{_d});
1079 66         1065 $x->{_d} = $LIB->_mul($x->{_d}, $y->{_n});
1080              
1081             # compute new sign
1082 66 100       719 $x->{sign} = $x->{sign} eq $y->{sign} ? '+' : '-';
1083              
1084 66         250 $x -> bnorm();
1085 66 100       152 if (wantarray) {
1086 6         24 my $rem = $x -> copy();
1087 6         32 $x = $x -> bfloor();
1088 6         33 $x = $x -> round(@r);
1089 6         20 $rem = $rem -> bsub($x -> copy()) -> bmul($y);
1090 6 50 33     33 $x = $downgrade -> new($x) if defined($downgrade) && $x -> is_int();
1091 6 50 33     21 $rem = $downgrade -> new($rem) if defined($downgrade) && $rem -> is_int();
1092 6         40 return $x, $rem;
1093             } else {
1094 60         251 return $x -> round(@r);
1095             }
1096             }
1097              
1098             sub bmod {
1099             # compute "remainder" (in Perl way) of $x / $y
1100              
1101             # set up parameters
1102 21     21 1 49 my ($class, $x, $y, @r) = (ref($_[0]), @_);
1103             # objectify is costly, so avoid it
1104 21 50 33     81 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) {
1105 0         0 ($class, $x, $y, @r) = objectify(2, @_);
1106             }
1107              
1108 21 50       57 return $x if $x->modify('bmod');
1109              
1110             # At least one argument is NaN. This is handled the same way as in
1111             # Math::BigInt -> bmod().
1112              
1113 21 100 100     47 if ($x -> is_nan() || $y -> is_nan()) {
1114 2         23 return $x -> bnan();
1115             }
1116              
1117             # Modulo zero. This is handled the same way as in Math::BigInt -> bmod().
1118              
1119 19 50       209 if ($y -> is_zero()) {
1120 0 0       0 return $downgrade -> bzero() if defined $downgrade;
1121 0         0 return $x;
1122             }
1123              
1124             # Numerator (dividend) is +/-inf. This is handled the same way as in
1125             # Math::BigInt -> bmod().
1126              
1127 19 50       55 if ($x -> is_inf()) {
1128 0         0 return $x -> bnan();
1129             }
1130              
1131             # Denominator (divisor) is +/-inf. This is handled the same way as in
1132             # Math::BigInt -> bmod().
1133              
1134 19 50       126 if ($y -> is_inf()) {
1135 0 0 0     0 if ($x -> is_zero() || $x -> bcmp(0) == $y -> bcmp(0)) {
1136 0 0 0     0 return $downgrade -> new($x) if defined($downgrade) && $x -> is_int();
1137 0         0 return $x;
1138             } else {
1139 0 0       0 return $downgrade -> binf($y -> sign()) if defined($downgrade);
1140 0         0 return $x -> binf($y -> sign());
1141             }
1142             }
1143              
1144             # At this point, both the numerator and denominator are finite numbers, and
1145             # the denominator (divisor) is non-zero.
1146              
1147 19 50       106 if ($x->is_zero()) { # 0 / 7 = 0, mod 0
1148 0 0       0 return $downgrade -> bzero() if defined $downgrade;
1149 0         0 return $x;
1150             }
1151              
1152             # Compute $x - $y * floor($x/$y). This can probably be optimized by working
1153             # on a lower level.
1154              
1155 19         31 $x -> bsub($x -> copy() -> bdiv($y) -> bfloor() -> bmul($y));
1156 19         60 return $x -> round(@r);
1157             }
1158              
1159             ##############################################################################
1160             # bdec/binc
1161              
1162             sub bdec {
1163             # decrement value (subtract 1)
1164 12 50   12 1 58 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_);
1165              
1166 12 100       76 if ($x->{sign} !~ /^[+-]$/) { # NaN, inf, -inf
1167 3 100       12 return $downgrade -> new($x) if defined $downgrade;
1168 1         9 return $x;
1169             }
1170              
1171 9 100       35 if ($x->{sign} eq '-') {
1172 1         7 $x->{_n} = $LIB->_add($x->{_n}, $x->{_d}); # -5/2 => -7/2
1173             } else {
1174 8 100       30 if ($LIB->_acmp($x->{_n}, $x->{_d}) < 0) # n < d?
1175             {
1176             # 1/3 -- => -2/3
1177 3         31 $x->{_n} = $LIB->_sub($LIB->_copy($x->{_d}), $x->{_n});
1178 3         100 $x->{sign} = '-';
1179             } else {
1180 5         57 $x->{_n} = $LIB->_sub($x->{_n}, $x->{_d}); # 5/2 => 3/2
1181             }
1182             }
1183 9         169 $x->bnorm()->round(@r);
1184             }
1185              
1186             sub binc {
1187             # increment value (add 1)
1188 13 50   13 1 64 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_);
1189              
1190 13 100       64 if ($x->{sign} !~ /^[+-]$/) { # NaN, inf, -inf
1191 3 100       14 return $downgrade -> new($x) if defined $downgrade;
1192 1         9 return $x;
1193             }
1194              
1195 10 100       40 if ($x->{sign} eq '-') {
1196 3 100       14 if ($LIB->_acmp($x->{_n}, $x->{_d}) < 0) {
1197             # -1/3 ++ => 2/3 (overflow at 0)
1198 2         18 $x->{_n} = $LIB->_sub($LIB->_copy($x->{_d}), $x->{_n});
1199 2         70 $x->{sign} = '+';
1200             } else {
1201 1         11 $x->{_n} = $LIB->_sub($x->{_n}, $x->{_d}); # -5/2 => -3/2
1202             }
1203             } else {
1204 7         34 $x->{_n} = $LIB->_add($x->{_n}, $x->{_d}); # 5/2 => 7/2
1205             }
1206 10         176 $x->bnorm()->round(@r);
1207             }
1208              
1209             sub binv {
1210 20     20 1 94 my $x = shift;
1211 20         37 my @r = @_;
1212              
1213 20 50       60 return $x if $x->modify('binv');
1214              
1215 20 100       51 return $x if $x -> is_nan();
1216 18 100       121 return $x -> bzero() if $x -> is_inf();
1217 14 100       105 return $x -> binf("+") if $x -> is_zero();
1218              
1219 12         30 ($x -> {_n}, $x -> {_d}) = ($x -> {_d}, $x -> {_n});
1220 12         35 $x -> round(@r);
1221             }
1222              
1223             ##############################################################################
1224             # is_foo methods (the rest is inherited)
1225              
1226             sub is_int {
1227             # return true if arg (BRAT or num_str) is an integer
1228 9820 50   9820 1 118807 my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_);
1229              
1230             return 1 if ($x->{sign} =~ /^[+-]$/) && # NaN and +-inf aren't
1231 9820 100 100     41896 $LIB->_is_one($x->{_d}); # x/y && y != 1 => no integer
1232 31         302 0;
1233             }
1234              
1235             sub is_zero {
1236             # return true if arg (BRAT or num_str) is zero
1237 649 50   649 1 1989 my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_);
1238              
1239 649 100 100     2361 return 1 if $x->{sign} eq '+' && $LIB->_is_zero($x->{_n});
1240 576         3466 0;
1241             }
1242              
1243             sub is_one {
1244             # return true if arg (BRAT or num_str) is +1 or -1 if signis given
1245 311 50   311 1 1308 my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_);
1246              
1247 311 50       735 croak "too many arguments for is_one()" if @_ > 2;
1248 311   100     977 my $sign = $_[1] || '';
1249 311 100       798 $sign = '+' if $sign ne '-';
1250             return 1 if ($x->{sign} eq $sign &&
1251 311 100 100     1072 $LIB->_is_one($x->{_n}) && $LIB->_is_one($x->{_d}));
      100        
1252 274         1864 0;
1253             }
1254              
1255             sub is_odd {
1256             # return true if arg (BFLOAT or num_str) is odd or false if even
1257 25 50   25 1 157 my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_);
1258              
1259             return 1 if ($x->{sign} =~ /^[+-]$/) && # NaN & +-inf aren't
1260 25 100 100     158 ($LIB->_is_one($x->{_d}) && $LIB->_is_odd($x->{_n})); # x/2 is not, but 3/1
      100        
1261 15         199 0;
1262             }
1263              
1264             sub is_even {
1265             # return true if arg (BINT or num_str) is even or false if odd
1266 18 50   18 1 107 my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_);
1267              
1268 18 100       70 return 0 if $x->{sign} !~ /^[+-]$/; # NaN & +-inf aren't
1269             return 1 if ($LIB->_is_one($x->{_d}) # x/3 is never
1270 15 100 100     37 && $LIB->_is_even($x->{_n})); # but 4/1 is
1271 9         126 0;
1272             }
1273              
1274             ##############################################################################
1275             # parts() and friends
1276              
1277             sub numerator {
1278 39 50   39 1 3612 my ($class, $x) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_);
1279              
1280             # NaN, inf, -inf
1281 39 100       211 return Math::BigInt->new($x->{sign}) if ($x->{sign} !~ /^[+-]$/);
1282              
1283 24         111 my $n = Math::BigInt->new($LIB->_str($x->{_n}));
1284 24         1552 $n->{sign} = $x->{sign};
1285 24         73 $n;
1286             }
1287              
1288             sub denominator {
1289 35 50   35 1 5619 my ($class, $x) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_);
1290              
1291             # NaN
1292 35 100       118 return Math::BigInt->new($x->{sign}) if $x->{sign} eq 'NaN';
1293             # inf, -inf
1294 26 100       137 return Math::BigInt->bone() if $x->{sign} !~ /^[+-]$/;
1295              
1296 20         63 Math::BigInt->new($LIB->_str($x->{_d}));
1297             }
1298              
1299             sub parts {
1300 11 50   11 1 67 my ($class, $x) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_);
1301              
1302 11         17 my $c = 'Math::BigInt';
1303              
1304 11 100       28 return ($c->bnan(), $c->bnan()) if $x->{sign} eq 'NaN';
1305 10 100       21 return ($c->binf(), $c->binf()) if $x->{sign} eq '+inf';
1306 9 100       19 return ($c->binf('-'), $c->binf()) if $x->{sign} eq '-inf';
1307              
1308 8         24 my $n = $c->new($LIB->_str($x->{_n}));
1309 8         518 $n->{sign} = $x->{sign};
1310 8         21 my $d = $c->new($LIB->_str($x->{_d}));
1311 8         485 ($n, $d);
1312             }
1313              
1314             sub dparts {
1315 16     16 1 41 my $x = shift;
1316 16         24 my $class = ref $x;
1317              
1318 16 50       30 croak("dparts() is an instance method") unless $class;
1319              
1320 16 100       38 if ($x -> is_nan()) {
1321 2 100       13 return $class -> bnan(), $class -> bnan() if wantarray;
1322 1         3 return $class -> bnan();
1323             }
1324              
1325 14 100       80 if ($x -> is_inf()) {
1326 4 100       38 return $class -> binf($x -> sign()), $class -> bzero() if wantarray;
1327 2         6 return $class -> binf($x -> sign());
1328             }
1329              
1330             # 355/113 => 3 + 16/113
1331              
1332 10         72 my ($q, $r) = $LIB -> _div($LIB -> _copy($x -> {_n}), $x -> {_d});
1333              
1334 10         182 my $int = Math::BigRat -> new($x -> {sign} . $LIB -> _str($q));
1335 10 100       30 return $int unless wantarray;
1336              
1337             my $frc = Math::BigRat -> new($x -> {sign} . $LIB -> _str($r),
1338 5         13 $LIB -> _str($x -> {_d}));
1339              
1340 5         16 return $int, $frc;
1341             }
1342              
1343             sub fparts {
1344 14     14 1 44 my $x = shift;
1345 14         19 my $class = ref $x;
1346              
1347 14 50       26 croak("fparts() is an instance method") unless $class;
1348              
1349 14 100       28 return ($class -> bnan(),
1350             $class -> bnan()) if $x -> is_nan();
1351              
1352 13         70 my $numer = $x -> copy();
1353 13         26 my $denom = $class -> bzero();
1354              
1355 13         27 $denom -> {_n} = $numer -> {_d};
1356 13         23 $numer -> {_d} = $LIB -> _one();
1357              
1358 13         89 return ($numer, $denom);
1359             }
1360              
1361             sub length {
1362 5 50   5 1 33 my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_);
1363              
1364 5 50       11 return $nan unless $x->is_int();
1365 5         44 $LIB->_len($x->{_n}); # length(-123/1) => length(123)
1366             }
1367              
1368             sub digit {
1369 11 50   11 1 56 my ($class, $x, $n) = ref($_[0]) ? (undef, $_[0], $_[1]) : objectify(1, @_);
1370              
1371 11 50       21 return $nan unless $x->is_int();
1372 11   100     93 $LIB->_digit($x->{_n}, $n || 0); # digit(-123/1, 2) => digit(123, 2)
1373             }
1374              
1375             ##############################################################################
1376             # special calc routines
1377              
1378             sub bceil {
1379 24 50   24 1 210 my ($class, $x) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_);
1380              
1381 24 100 100     163 if ($x->{sign} !~ /^[+-]$/ || # NaN or inf or
1382             $LIB->_is_one($x->{_d})) # integer
1383             {
1384 10 100       63 return $downgrade -> new($x) if defined $downgrade;
1385 8         82 return $x;
1386             }
1387              
1388 14         180 $x->{_n} = $LIB->_div($x->{_n}, $x->{_d}); # 22/7 => 3/1 w/ truncate
1389 14         193 $x->{_d} = $LIB->_one(); # d => 1
1390 14 100       142 $x->{_n} = $LIB->_inc($x->{_n}) if $x->{sign} eq '+'; # +22/7 => 4/1
1391 14 100 100     125 $x->{sign} = '+' if $x->{sign} eq '-' && $LIB->_is_zero($x->{_n}); # -0 => 0
1392 14 100       111 return $downgrade -> new($x) if defined $downgrade;
1393 13         171 $x;
1394             }
1395              
1396             sub bfloor {
1397 52 50   52 1 284 my ($class, $x) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_);
1398              
1399 52 100 100     286 if ($x->{sign} !~ /^[+-]$/ || # NaN or inf or
1400             $LIB->_is_one($x->{_d})) # integer
1401             {
1402 24 100       156 return $downgrade -> new($x) if defined $downgrade;
1403 22         137 return $x;
1404             }
1405              
1406 28         302 $x->{_n} = $LIB->_div($x->{_n}, $x->{_d}); # 22/7 => 3/1 w/ truncate
1407 28         373 $x->{_d} = $LIB->_one(); # d => 1
1408 28 100       249 $x->{_n} = $LIB->_inc($x->{_n}) if $x->{sign} eq '-'; # -22/7 => -4/1
1409 28 100       202 return $downgrade -> new($x) if defined $downgrade;
1410 27         235 $x;
1411             }
1412              
1413             sub bint {
1414 963 50   963 1 2087 my ($class, $x) = ref($_[0]) ? (ref($_[0]), $_[0]) : objectify(1, @_);
1415              
1416 963 100 100     3999 if ($x->{sign} !~ /^[+-]$/ || # NaN or inf or
1417             $LIB->_is_one($x->{_d})) # integer
1418             {
1419 552 100       3431 return $downgrade -> new($x) if defined $downgrade;
1420 550         1554 return $x;
1421             }
1422              
1423 411         3015 $x->{_n} = $LIB->_div($x->{_n}, $x->{_d}); # 22/7 => 3/1 w/ truncate
1424 411         3933 $x->{_d} = $LIB->_one(); # d => 1
1425 411 100 66     2274 $x->{sign} = '+' if $x->{sign} eq '-' && $LIB -> _is_zero($x->{_n});
1426 411 100       746 return $downgrade -> new($x) if defined $downgrade;
1427 410         1125 return $x;
1428             }
1429              
1430             sub bfac {
1431 13 50   13 1 67 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_);
1432              
1433             # if $x is not an integer
1434 13 100 66     59 if (($x->{sign} ne '+') || (!$LIB->_is_one($x->{_d}))) {
1435 3         15 return $x->bnan();
1436             }
1437              
1438 10         80 $x->{_n} = $LIB->_fac($x->{_n});
1439             # since _d is 1, we don't need to reduce/norm the result
1440 10         209 $x->round(@r);
1441             }
1442              
1443             sub bpow {
1444             # power ($x ** $y)
1445              
1446             # set up parameters
1447 190     190 1 2198 my ($class, $x, $y, @r) = (ref($_[0]), @_);
1448              
1449             # objectify is costly, so avoid it
1450 190 100 66     5902 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) {
1451 6         21 ($class, $x, $y, @r) = objectify(2, @_);
1452             }
1453              
1454 190 50       956 return $x if $x->modify('bpow');
1455              
1456             # $x and/or $y is a NaN
1457 190 100 100     643 return $x->bnan() if $x->is_nan() || $y->is_nan();
1458              
1459             # $x and/or $y is a +/-Inf
1460 161 100       2181 if ($x->is_inf("-")) {
    100          
    100          
    100          
1461 13 100       316 return $x->bzero() if $y->is_negative();
1462 7 100       258 return $x->bnan() if $y->is_zero();
1463 6 100       21 return $x if $y->is_odd();
1464 4         16 return $x->bneg();
1465             } elsif ($x->is_inf("+")) {
1466 13 100       843 return $x->bzero() if $y->is_negative();
1467 7 100       264 return $x->bnan() if $y->is_zero();
1468 6         84 return $x;
1469             } elsif ($y->is_inf("-")) {
1470 11 100       947 return $x->bnan() if $x -> is_one("-");
1471 10 100 100     43 return $x->binf("+") if $x > -1 && $x < 1;
1472 7 100       27 return $x->bone() if $x -> is_one("+");
1473 6         26 return $x->bzero();
1474             } elsif ($y->is_inf("+")) {
1475 11 100       1081 return $x->bnan() if $x -> is_one("-");
1476 10 100 100     44 return $x->bzero() if $x > -1 && $x < 1;
1477 7 100       29 return $x->bone() if $x -> is_one("+");
1478 6         19 return $x->binf("+");
1479             }
1480              
1481 113 100       11618 if ($x -> is_zero()) {
1482 11 100       116 return $x -> bone() if $y -> is_zero();
1483 10 100       102 return $x -> binf() if $y -> is_negative();
1484 5         286 return $x;
1485             }
1486              
1487             # We don't support complex numbers, so upgrade or return NaN.
1488              
1489 102 100 100     1041 if ($x -> is_negative() && !$y -> is_int()) {
1490 20 50       70 return $upgrade -> bpow($upgrade -> new($x), $y, @r)
1491             if defined $upgrade;
1492 20         93 return $x -> bnan();
1493             }
1494              
1495 82 100 100     2990 if ($x -> is_one("+") || $y -> is_one()) {
1496 20         636 return $x;
1497             }
1498              
1499 62 100       166 if ($x -> is_one("-")) {
1500 6 100       89 return $x if $y -> is_odd();
1501 3         18 return $x -> bneg();
1502             }
1503              
1504             # (a/b)^-(c/d) = (b/a)^(c/d)
1505 56 100       231 ($x->{_n}, $x->{_d}) = ($x->{_d}, $x->{_n}) if $y->is_negative();
1506              
1507 56 100       1432 unless ($LIB->_is_one($y->{_n})) {
1508 47         431 $x->{_n} = $LIB->_pow($x->{_n}, $y->{_n});
1509 47         3498 $x->{_d} = $LIB->_pow($x->{_d}, $y->{_n});
1510 47 100 100     2669 $x->{sign} = '+' if $x->{sign} eq '-' && $LIB->_is_even($y->{_n});
1511             }
1512              
1513 56 100       322 unless ($LIB->_is_one($y->{_d})) {
1514 2 100       32 return $x->bsqrt(@r) if $LIB->_is_two($y->{_d}); # 1/2 => sqrt
1515 1         49 return $x->broot($LIB->_str($y->{_d}), @r); # 1/N => root(N)
1516             }
1517              
1518 54         444 return $x->round(@r);
1519             }
1520              
1521             sub blog {
1522             # Return the logarithm of the operand. If a second operand is defined, that
1523             # value is used as the base, otherwise the base is assumed to be Euler's
1524             # constant.
1525              
1526 20     20 1 79 my ($class, $x, $base, @r);
1527              
1528             # Don't objectify the base, since an undefined base, as in $x->blog() or
1529             # $x->blog(undef) signals that the base is Euler's number.
1530              
1531 20 50 33     65 if (!ref($_[0]) && $_[0] =~ /^[A-Za-z]|::/) {
1532             # E.g., Math::BigRat->blog(256, 2)
1533 0 0       0 ($class, $x, $base, @r) =
1534             defined $_[2] ? objectify(2, @_) : objectify(1, @_);
1535             } else {
1536             # E.g., Math::BigRat::blog(256, 2) or $x->blog(2)
1537 20 100       78 ($class, $x, $base, @r) =
1538             defined $_[1] ? objectify(2, @_) : objectify(1, @_);
1539             }
1540              
1541 20 50       163 return $x if $x->modify('blog');
1542              
1543             # Handle all exception cases and all trivial cases. I have used Wolfram Alpha
1544             # (http://www.wolframalpha.com) as the reference for these cases.
1545              
1546 20 100       50 return $x -> bnan() if $x -> is_nan();
1547              
1548 15 100       109 if (defined $base) {
1549 7 50       17 $base = $class -> new($base) unless ref $base;
1550 7 100 66     16 if ($base -> is_nan() || $base -> is_one()) {
    50 33        
    100          
1551 2         13 return $x -> bnan();
1552             } elsif ($base -> is_inf() || $base -> is_zero()) {
1553 0 0 0     0 return $x -> bnan() if $x -> is_inf() || $x -> is_zero();
1554 0         0 return $x -> bzero();
1555             } elsif ($base -> is_negative()) { # -inf < base < 0
1556 2 50       53 return $x -> bzero() if $x -> is_one(); # x = 1
1557 2 50       5 return $x -> bone() if $x == $base; # x = base
1558 2         5 return $x -> bnan(); # otherwise
1559             }
1560 3 50       110 return $x -> bone() if $x == $base; # 0 < base && 0 < x < inf
1561             }
1562              
1563             # We now know that the base is either undefined or positive and finite.
1564              
1565 11 100       29 if ($x -> is_inf()) { # x = +/-inf
    100          
    100          
    100          
1566 2 50 33     22 my $sign = defined $base && $base < 1 ? '-' : '+';
1567 2         6 return $x -> binf($sign);
1568             } elsif ($x -> is_neg()) { # -inf < x < 0
1569 2         97 return $x -> bnan();
1570             } elsif ($x -> is_one()) { # x = 1
1571 1         15 return $x -> bzero();
1572             } elsif ($x -> is_zero()) { # x = 0
1573 3 50 66     33 my $sign = defined $base && $base < 1 ? '+' : '-';
1574 3         10 return $x -> binf($sign);
1575             }
1576              
1577             # Now take care of the cases where $x and/or $base is 1/N.
1578             #
1579             # log(1/N) / log(B) = -log(N)/log(B)
1580             # log(1/N) / log(1/B) = log(N)/log(B)
1581             # log(N) / log(1/B) = -log(N)/log(B)
1582              
1583 3         9 my $neg = 0;
1584 3 50       17 if ($x -> numerator() -> is_one()) {
1585 0         0 $x -> binv();
1586 0         0 $neg = !$neg;
1587             }
1588 3 100 66     64 if (defined(blessed($base)) && $base -> isa($class)) {
1589 2 50       6 if ($base -> numerator() -> is_one()) {
1590 0         0 $base = $base -> copy() -> binv();
1591 0         0 $neg = !$neg;
1592             }
1593             }
1594              
1595             # disable upgrading and downgrading
1596              
1597 3         52 require Math::BigFloat;
1598 3         20 my $upg = Math::BigFloat -> upgrade();
1599 3         44 my $dng = Math::BigFloat -> downgrade();
1600 3         36 Math::BigFloat -> upgrade(undef);
1601 3         30 Math::BigFloat -> downgrade(undef);
1602              
1603             # At this point we are done handling all exception cases and trivial cases.
1604              
1605 3 100       31 $base = Math::BigFloat -> new($base) if defined $base;
1606 3         113 my $xnum = Math::BigFloat -> new($LIB -> _str($x->{_n}));
1607 3         222 my $xden = Math::BigFloat -> new($LIB -> _str($x->{_d}));
1608 3         452 my $xstr = $xnum -> bdiv($xden) -> blog($base, @r) -> bsstr();
1609              
1610             # reset upgrading and downgrading
1611              
1612 3         282317 Math::BigFloat -> upgrade($upg);
1613 3         41 Math::BigFloat -> downgrade($dng);
1614              
1615 3         50 my $xobj = Math::BigRat -> new($xstr);
1616 3         18 $x -> {sign} = $xobj -> {sign};
1617 3         11 $x -> {_n} = $xobj -> {_n};
1618 3         11 $x -> {_d} = $xobj -> {_d};
1619              
1620 3 50       125 return $neg ? $x -> bneg() : $x;
1621             }
1622              
1623             sub bexp {
1624             # set up parameters
1625 1     1 1 4 my ($class, $x, $y, @r) = (ref($_[0]), @_);
1626              
1627             # objectify is costly, so avoid it
1628 1 50 33     8 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) {
1629 1         6 ($class, $x, $y, @r) = objectify(1, @_);
1630             }
1631              
1632 1 50       8 return $x->binf(@r) if $x->{sign} eq '+inf';
1633 1 50       3 return $x->bzero(@r) if $x->{sign} eq '-inf';
1634              
1635             # we need to limit the accuracy to protect against overflow
1636 1         3 my $fallback = 0;
1637 1         2 my ($scale, @params);
1638 1         6 ($x, @params) = $x->_find_round_parameters(@r);
1639              
1640             # also takes care of the "error in _find_round_parameters?" case
1641 1 50       31 return $x if $x->{sign} eq 'NaN';
1642              
1643             # no rounding at all, so must use fallback
1644 1 50       12 if (scalar @params == 0) {
1645             # simulate old behaviour
1646 1         7 $params[0] = $class->div_scale(); # and round to it as accuracy
1647 1         14 $params[1] = undef; # P = undef
1648 1         2 $scale = $params[0]+4; # at least four more for proper round
1649 1         2 $params[2] = $r[2]; # round mode by caller or undef
1650 1         2 $fallback = 1; # to clear a/p afterwards
1651             } else {
1652             # the 4 below is empirical, and there might be cases where it's not enough...
1653 0   0     0 $scale = abs($params[0] || $params[1]) + 4; # take whatever is defined
1654             }
1655              
1656 1 50       4 return $x->bone(@params) if $x->is_zero();
1657              
1658             # See the comments in Math::BigFloat on how this algorithm works.
1659             # Basically we calculate A and B (where B is faculty(N)) so that A/B = e
1660              
1661 1         4 my $x_org = $x->copy();
1662 1 50       3 if ($scale <= 75) {
1663             # set $x directly from a cached string form
1664             $x->{_n} =
1665 1         3 $LIB->_new("90933395208605785401971970164779391644753259799242");
1666             $x->{_d} =
1667 1         35 $LIB->_new("33452526613163807108170062053440751665152000000000");
1668 1         19 $x->{sign} = '+';
1669             } else {
1670             # compute A and B so that e = A / B.
1671              
1672             # After some terms we end up with this, so we use it as a starting point:
1673 0         0 my $A = $LIB->_new("90933395208605785401971970164779391644753259799242");
1674 0         0 my $F = $LIB->_new(42); my $step = 42;
  0         0  
1675              
1676             # Compute how many steps we need to take to get $A and $B sufficiently big
1677 0         0 my $steps = Math::BigFloat::_len_to_steps($scale - 4);
1678             # print STDERR "# Doing $steps steps for ", $scale-4, " digits\n";
1679 0         0 while ($step++ <= $steps) {
1680             # calculate $a * $f + 1
1681 0         0 $A = $LIB->_mul($A, $F);
1682 0         0 $A = $LIB->_inc($A);
1683             # increment f
1684 0         0 $F = $LIB->_inc($F);
1685             }
1686             # compute $B as factorial of $steps (this is faster than doing it manually)
1687 0         0 my $B = $LIB->_fac($LIB->_new($steps));
1688              
1689             # print "A ", $LIB->_str($A), "\nB ", $LIB->_str($B), "\n";
1690              
1691 0         0 $x->{_n} = $A;
1692 0         0 $x->{_d} = $B;
1693 0         0 $x->{sign} = '+';
1694             }
1695              
1696             # $x contains now an estimate of e, with some surplus digits, so we can round
1697 1 50       5 if (!$x_org->is_one()) {
1698             # raise $x to the wanted power and round it in one step:
1699 1         15 $x->bpow($x_org, @params);
1700             } else {
1701             # else just round the already computed result
1702 0         0 delete $x->{_a}; delete $x->{_p};
  0         0  
1703             # shortcut to not run through _find_round_parameters again
1704 0 0       0 if (defined $params[0]) {
1705 0         0 $x->bround($params[0], $params[2]); # then round accordingly
1706             } else {
1707 0         0 $x->bfround($params[1], $params[2]); # then round accordingly
1708             }
1709             }
1710 1 50       4 if ($fallback) {
1711             # clear a/p after round, since user did not request it
1712 1         3 delete $x->{_a}; delete $x->{_p};
  1         2  
1713             }
1714              
1715 1         7 $x;
1716             }
1717              
1718             sub bnok {
1719             # set up parameters
1720 4956     4956 1 37814 my ($class, $x, $y, @r) = (ref($_[0]), @_);
1721              
1722             # objectify is costly, so avoid it
1723 4956 100 66     24462 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) {
1724 2478         6970 ($class, $x, $y, @r) = objectify(2, @_);
1725             }
1726              
1727 4956 100 100     31160 return $x->bnan() if $x->is_nan() || $y->is_nan();
1728 4932 50 66     58032 return $x->bnan() if (($x->is_finite() && !$x->is_int()) ||
      66        
      33        
1729             ($y->is_finite() && !$y->is_int()));
1730              
1731 4932         45346 my $xint = Math::BigInt -> new($x -> bstr());
1732 4932         272538 my $yint = Math::BigInt -> new($y -> bstr());
1733 4932         258804 $xint -> bnok($yint);
1734 4932         3242644 my $xrat = Math::BigRat -> new($xint);
1735              
1736 4932         9999 $x -> {sign} = $xrat -> {sign};
1737 4932         9939 $x -> {_n} = $xrat -> {_n};
1738 4932         8778 $x -> {_d} = $xrat -> {_d};
1739              
1740 4932         76861 return $x;
1741             }
1742              
1743             sub broot {
1744             # set up parameters
1745 7     7 1 35 my ($class, $x, $y, @r) = (ref($_[0]), @_);
1746             # objectify is costly, so avoid it
1747 7 100 66     47 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) {
1748 5         19 ($class, $x, $y, @r) = objectify(2, @_);
1749             }
1750              
1751             # Convert $x into a Math::BigFloat.
1752              
1753 7         61 my $xd = Math::BigFloat -> new($LIB -> _str($x->{_d}));
1754 7         494 my $xflt = Math::BigFloat -> new($LIB -> _str($x->{_n})) -> bdiv($xd);
1755 7         3340 $xflt -> {sign} = $x -> {sign};
1756              
1757             # Convert $y into a Math::BigFloat.
1758              
1759 7         24 my $yd = Math::BigFloat -> new($LIB -> _str($y->{_d}));
1760 7         544 my $yflt = Math::BigFloat -> new($LIB -> _str($y->{_n})) -> bdiv($yd);
1761 7         1958 $yflt -> {sign} = $y -> {sign};
1762              
1763             # Compute the root and convert back to a Math::BigRat.
1764              
1765 7         34 $xflt -> broot($yflt, @r);
1766 7         290376 my $xtmp = Math::BigRat -> new($xflt -> bsstr());
1767              
1768 7         20 $x -> {sign} = $xtmp -> {sign};
1769 7         18 $x -> {_n} = $xtmp -> {_n};
1770 7         21 $x -> {_d} = $xtmp -> {_d};
1771              
1772 7         88 return $x;
1773             }
1774              
1775             sub bmodpow {
1776             # set up parameters
1777 19     19 1 101 my ($class, $x, $y, $m, @r) = (ref($_[0]), @_);
1778             # objectify is costly, so avoid it
1779 19 50 33     77 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) {
1780 0         0 ($class, $x, $y, $m, @r) = objectify(3, @_);
1781             }
1782              
1783             # Convert $x, $y, and $m into Math::BigInt objects.
1784              
1785 19         38 my $xint = Math::BigInt -> new($x -> copy() -> bint());
1786 19         877 my $yint = Math::BigInt -> new($y -> copy() -> bint());
1787 19         828 my $mint = Math::BigInt -> new($m -> copy() -> bint());
1788              
1789 19         744 $xint -> bmodpow($yint, $mint, @r);
1790 19         62032 my $xtmp = Math::BigRat -> new($xint -> bsstr());
1791              
1792 19         41 $x -> {sign} = $xtmp -> {sign};
1793 19         35 $x -> {_n} = $xtmp -> {_n};
1794 19         30 $x -> {_d} = $xtmp -> {_d};
1795 19         236 return $x;
1796             }
1797              
1798             sub bmodinv {
1799             # set up parameters
1800 17     17 1 92 my ($class, $x, $y, @r) = (ref($_[0]), @_);
1801             # objectify is costly, so avoid it
1802 17 50 33     71 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) {
1803 0         0 ($class, $x, $y, @r) = objectify(2, @_);
1804             }
1805              
1806             # Convert $x and $y into Math::BigInt objects.
1807              
1808 17         36 my $xint = Math::BigInt -> new($x -> copy() -> bint());
1809 17         785 my $yint = Math::BigInt -> new($y -> copy() -> bint());
1810              
1811 17         750 $xint -> bmodinv($yint, @r);
1812 17         5038 my $xtmp = Math::BigRat -> new($xint -> bsstr());
1813              
1814 17         34 $x -> {sign} = $xtmp -> {sign};
1815 17         31 $x -> {_n} = $xtmp -> {_n};
1816 17         27 $x -> {_d} = $xtmp -> {_d};
1817 17         187 return $x;
1818             }
1819              
1820             sub bsqrt {
1821 20 50   20 1 137 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_);
1822              
1823 20 100       99 return $x->bnan() if $x->{sign} !~ /^[+]/; # NaN, -inf or < 0
1824 16 100       47 return $x if $x->{sign} eq '+inf'; # sqrt(inf) == inf
1825 15 100 100     63 return $x->round(@r) if $x->is_zero() || $x->is_one();
1826              
1827 13         42 my $n = $x -> {_n};
1828 13         22 my $d = $x -> {_d};
1829              
1830             # Look for an exact solution. For the numerator and the denominator, take
1831             # the square root and square it and see if we got the original value. If we
1832             # did, for both the numerator and the denominator, we have an exact
1833             # solution.
1834              
1835             {
1836 13         15 my $nsqrt = $LIB -> _sqrt($LIB -> _copy($n));
  13         36  
1837 13         1148 my $n2 = $LIB -> _mul($LIB -> _copy($nsqrt), $nsqrt);
1838 13 100       247 if ($LIB -> _acmp($n, $n2) == 0) {
1839 11         77 my $dsqrt = $LIB -> _sqrt($LIB -> _copy($d));
1840 11         145 my $d2 = $LIB -> _mul($LIB -> _copy($dsqrt), $dsqrt);
1841 11 100       145 if ($LIB -> _acmp($d, $d2) == 0) {
1842 10         66 $x -> {_n} = $nsqrt;
1843 10         16 $x -> {_d} = $dsqrt;
1844 10         29 return $x->round(@r);
1845             }
1846             }
1847             }
1848              
1849 3         44 local $Math::BigFloat::upgrade = undef;
1850 3         22 local $Math::BigFloat::downgrade = undef;
1851 3         9 local $Math::BigFloat::precision = undef;
1852 3         6 local $Math::BigFloat::accuracy = undef;
1853 3         6 local $Math::BigInt::upgrade = undef;
1854 3         5 local $Math::BigInt::precision = undef;
1855 3         5 local $Math::BigInt::accuracy = undef;
1856              
1857 3         11 my $xn = Math::BigFloat -> new($LIB -> _str($n));
1858 3         263 my $xd = Math::BigFloat -> new($LIB -> _str($d));
1859              
1860 3         345 my $xtmp = Math::BigRat -> new($xn -> bdiv($xd) -> bsqrt() -> bsstr());
1861              
1862 3         11 $x -> {sign} = $xtmp -> {sign};
1863 3         31 $x -> {_n} = $xtmp -> {_n};
1864 3         8 $x -> {_d} = $xtmp -> {_d};
1865              
1866 3         16 $x->round(@r);
1867             }
1868              
1869             sub blsft {
1870 0     0 1 0 my ($class, $x, $y, $b) = objectify(2, @_);
1871              
1872 0 0       0 $b = 2 if !defined $b;
1873 0 0 0     0 $b = $class -> new($b) unless ref($b) && $b -> isa($class);
1874              
1875 0 0 0     0 return $x -> bnan() if $x -> is_nan() || $y -> is_nan() || $b -> is_nan();
      0        
1876              
1877             # shift by a negative amount?
1878 0 0       0 return $x -> brsft($y -> copy() -> babs(), $b) if $y -> {sign} =~ /^-/;
1879              
1880 0         0 $x -> bmul($b -> bpow($y));
1881             }
1882              
1883             sub brsft {
1884 0     0 1 0 my ($class, $x, $y, $b) = objectify(2, @_);
1885              
1886 0 0       0 $b = 2 if !defined $b;
1887 0 0 0     0 $b = $class -> new($b) unless ref($b) && $b -> isa($class);
1888              
1889 0 0 0     0 return $x -> bnan() if $x -> is_nan() || $y -> is_nan() || $b -> is_nan();
      0        
1890              
1891             # shift by a negative amount?
1892 0 0       0 return $x -> blsft($y -> copy() -> babs(), $b) if $y -> {sign} =~ /^-/;
1893              
1894             # the following call to bdiv() will return either quotient (scalar context)
1895             # or quotient and remainder (list context).
1896 0         0 $x -> bdiv($b -> bpow($y));
1897             }
1898              
1899             sub band {
1900 289     289 1 316 my $x = shift;
1901 289         354 my $xref = ref($x);
1902 289   33     412 my $class = $xref || $x;
1903              
1904 289 50       378 croak 'band() is an instance method, not a class method' unless $xref;
1905 289 50       430 croak 'Not enough arguments for band()' if @_ < 1;
1906              
1907 289         331 my $y = shift;
1908 289 50       435 $y = $class -> new($y) unless ref($y);
1909              
1910 289         425 my @r = @_;
1911              
1912 289         518 my $xtmp = Math::BigInt -> new($x -> bint()); # to Math::BigInt
1913 289         12287 $xtmp -> band($y);
1914 289         31776 $xtmp = $class -> new($xtmp); # back to Math::BigRat
1915              
1916 289         579 $x -> {sign} = $xtmp -> {sign};
1917 289         420 $x -> {_n} = $xtmp -> {_n};
1918 289         449 $x -> {_d} = $xtmp -> {_d};
1919              
1920 289         530 return $x -> round(@r);
1921             }
1922              
1923             sub bior {
1924 289     289 1 473 my $x = shift;
1925 289         475 my $xref = ref($x);
1926 289   33     528 my $class = $xref || $x;
1927              
1928 289 50       475 croak 'bior() is an instance method, not a class method' unless $xref;
1929 289 50       522 croak 'Not enough arguments for bior()' if @_ < 1;
1930              
1931 289         361 my $y = shift;
1932 289 50       509 $y = $class -> new($y) unless ref($y);
1933              
1934 289         544 my @r = @_;
1935              
1936 289         758 my $xtmp = Math::BigInt -> new($x -> bint()); # to Math::BigInt
1937 289         12490 $xtmp -> bior($y);
1938 289         37103 $xtmp = $class -> new($xtmp); # back to Math::BigRat
1939              
1940 289         707 $x -> {sign} = $xtmp -> {sign};
1941 289         489 $x -> {_n} = $xtmp -> {_n};
1942 289         423 $x -> {_d} = $xtmp -> {_d};
1943              
1944 289         717 return $x -> round(@r);
1945             }
1946              
1947             sub bxor {
1948 289     289 1 345 my $x = shift;
1949 289         363 my $xref = ref($x);
1950 289   33     462 my $class = $xref || $x;
1951              
1952 289 50       419 croak 'bxor() is an instance method, not a class method' unless $xref;
1953 289 50       465 croak 'Not enough arguments for bxor()' if @_ < 1;
1954              
1955 289         298 my $y = shift;
1956 289 50       425 $y = $class -> new($y) unless ref($y);
1957              
1958 289         416 my @r = @_;
1959              
1960 289         526 my $xtmp = Math::BigInt -> new($x -> bint()); # to Math::BigInt
1961 289         12288 $xtmp -> bxor($y);
1962 289         34679 $xtmp = $class -> new($xtmp); # back to Math::BigRat
1963              
1964 289         582 $x -> {sign} = $xtmp -> {sign};
1965 289         429 $x -> {_n} = $xtmp -> {_n};
1966 289         406 $x -> {_d} = $xtmp -> {_d};
1967              
1968 289         481 return $x -> round(@r);
1969             }
1970              
1971             sub bnot {
1972 0     0 1 0 my $x = shift;
1973 0         0 my $xref = ref($x);
1974 0   0     0 my $class = $xref || $x;
1975              
1976 0 0       0 croak 'bnot() is an instance method, not a class method' unless $xref;
1977              
1978 0         0 my @r = @_;
1979              
1980 0         0 my $xtmp = Math::BigInt -> new($x -> bint()); # to Math::BigInt
1981 0         0 $xtmp -> bnot();
1982 0         0 $xtmp = $class -> new($xtmp); # back to Math::BigRat
1983              
1984 0         0 $x -> {sign} = $xtmp -> {sign};
1985 0         0 $x -> {_n} = $xtmp -> {_n};
1986 0         0 $x -> {_d} = $xtmp -> {_d};
1987              
1988 0         0 return $x -> round(@r);
1989             }
1990              
1991             ##############################################################################
1992             # round
1993              
1994             sub round {
1995 1247     1247 1 2064 my $x = shift;
1996 1247 0 33     2288 return $downgrade -> new($x) if defined($downgrade) &&
      66        
1997             ($x -> is_int() || $x -> is_inf() || $x -> is_nan());
1998 1245         11393 $x;
1999             }
2000              
2001             sub bround {
2002 4     4 1 6 my $x = shift;
2003 4 50 66     15 return $downgrade -> new($x) if defined($downgrade) &&
      33        
2004             ($x -> is_int() || $x -> is_inf() || $x -> is_nan());
2005 0         0 $x;
2006             }
2007              
2008             sub bfround {
2009 4     4 1 5 my $x = shift;
2010 4 50 66     17 return $downgrade -> new($x) if defined($downgrade) &&
      33        
2011             ($x -> is_int() || $x -> is_inf() || $x -> is_nan());
2012 0         0 $x;
2013             }
2014              
2015             ##############################################################################
2016             # comparing
2017              
2018             sub bcmp {
2019             # compare two signed numbers
2020              
2021             # set up parameters
2022 54     54 1 164 my ($class, $x, $y) = (ref($_[0]), @_);
2023              
2024             # objectify is costly, so avoid it
2025 54 100 66     257 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) {
2026 36         111 ($class, $x, $y) = objectify(2, @_);
2027             }
2028              
2029 54 50 33     623 if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/) {
2030             # $x is NaN and/or $y is NaN
2031 0 0 0     0 return if $x->{sign} eq $nan || $y->{sign} eq $nan;
2032             # $x and $y are both either +inf or -inf
2033 0 0 0     0 return 0 if $x->{sign} eq $y->{sign} && $x->{sign} =~ /^[+-]inf$/;
2034             # $x = +inf and $y < +inf
2035 0 0       0 return +1 if $x->{sign} eq '+inf';
2036             # $x = -inf and $y > -inf
2037 0 0       0 return -1 if $x->{sign} eq '-inf';
2038             # $x < +inf and $y = +inf
2039 0 0       0 return -1 if $y->{sign} eq '+inf';
2040             # $x > -inf and $y = -inf
2041 0         0 return +1;
2042             }
2043              
2044             # $x >= 0 and $y < 0
2045 54 100 100     240 return 1 if $x->{sign} eq '+' && $y->{sign} eq '-';
2046             # $x < 0 and $y >= 0
2047 40 100 100     175 return -1 if $x->{sign} eq '-' && $y->{sign} eq '+';
2048              
2049             # At this point, we know that $x and $y have the same sign.
2050              
2051             # shortcut
2052 35         111 my $xz = $LIB->_is_zero($x->{_n});
2053 35         223 my $yz = $LIB->_is_zero($y->{_n});
2054 35 50 66     250 return 0 if $xz && $yz; # 0 <=> 0
2055 35 100 66     125 return -1 if $xz && $y->{sign} eq '+'; # 0 <=> +y
2056 32 50 33     85 return 1 if $yz && $x->{sign} eq '+'; # +x <=> 0
2057              
2058 32         120 my $t = $LIB->_mul($LIB->_copy($x->{_n}), $y->{_d});
2059 32         632 my $u = $LIB->_mul($LIB->_copy($y->{_n}), $x->{_d});
2060              
2061 32         376 my $cmp = $LIB->_acmp($t, $u); # signs are equal
2062 32 100       214 $cmp = -$cmp if $x->{sign} eq '-'; # both are '-' => reverse
2063 32         106 $cmp;
2064             }
2065              
2066             sub bacmp {
2067             # compare two numbers (as unsigned)
2068              
2069             # set up parameters
2070 50     50 1 479 my ($class, $x, $y) = (ref($_[0]), @_);
2071             # objectify is costly, so avoid it
2072 50 50 33     311 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1]))) {
2073 0         0 ($class, $x, $y) = objectify(2, @_);
2074             }
2075              
2076 50 100 100     346 if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/)) {
2077             # handle +-inf and NaN
2078 35 100 100     261 return if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
2079 28 100 100     191 return 0 if $x->{sign} =~ /^[+-]inf$/ && $y->{sign} =~ /^[+-]inf$/;
2080 24 100 66     287 return 1 if $x->{sign} =~ /^[+-]inf$/ && $y->{sign} !~ /^[+-]inf$/;
2081 12         163 return -1;
2082             }
2083              
2084 15         65 my $t = $LIB->_mul($LIB->_copy($x->{_n}), $y->{_d});
2085 15         332 my $u = $LIB->_mul($LIB->_copy($y->{_n}), $x->{_d});
2086 15         185 $LIB->_acmp($t, $u); # ignore signs
2087             }
2088              
2089             sub beq {
2090 10     10 1 21 my $self = shift;
2091 10         20 my $selfref = ref $self;
2092             #my $class = $selfref || $self;
2093              
2094 10 50       27 croak 'beq() is an instance method, not a class method' unless $selfref;
2095 10 50       23 croak 'Wrong number of arguments for beq()' unless @_ == 1;
2096              
2097 10         27 my $cmp = $self -> bcmp(shift);
2098 10   66     74 return defined($cmp) && ! $cmp;
2099             }
2100              
2101             sub bne {
2102 0     0 1 0 my $self = shift;
2103 0         0 my $selfref = ref $self;
2104             #my $class = $selfref || $self;
2105              
2106 0 0       0 croak 'bne() is an instance method, not a class method' unless $selfref;
2107 0 0       0 croak 'Wrong number of arguments for bne()' unless @_ == 1;
2108              
2109 0         0 my $cmp = $self -> bcmp(shift);
2110 0 0 0     0 return defined($cmp) && ! $cmp ? '' : 1;
2111             }
2112              
2113             sub blt {
2114 19     19 1 39 my $self = shift;
2115 19         38 my $selfref = ref $self;
2116             #my $class = $selfref || $self;
2117              
2118 19 50       57 croak 'blt() is an instance method, not a class method' unless $selfref;
2119 19 50       64 croak 'Wrong number of arguments for blt()' unless @_ == 1;
2120              
2121 19         48 my $cmp = $self -> bcmp(shift);
2122 19   66     173 return defined($cmp) && $cmp < 0;
2123             }
2124              
2125             sub ble {
2126 0     0 1 0 my $self = shift;
2127 0         0 my $selfref = ref $self;
2128             #my $class = $selfref || $self;
2129              
2130 0 0       0 croak 'ble() is an instance method, not a class method' unless $selfref;
2131 0 0       0 croak 'Wrong number of arguments for ble()' unless @_ == 1;
2132              
2133 0         0 my $cmp = $self -> bcmp(shift);
2134 0   0     0 return defined($cmp) && $cmp <= 0;
2135             }
2136              
2137             sub bgt {
2138 24     24 1 59 my $self = shift;
2139 24         50 my $selfref = ref $self;
2140             #my $class = $selfref || $self;
2141              
2142 24 50       76 croak 'bgt() is an instance method, not a class method' unless $selfref;
2143 24 50       75 croak 'Wrong number of arguments for bgt()' unless @_ == 1;
2144              
2145 24         104 my $cmp = $self -> bcmp(shift);
2146 24   66     248 return defined($cmp) && $cmp > 0;
2147             }
2148              
2149             sub bge {
2150 0     0 1 0 my $self = shift;
2151 0         0 my $selfref = ref $self;
2152             #my $class = $selfref || $self;
2153              
2154 0 0       0 croak 'bge() is an instance method, not a class method'
2155             unless $selfref;
2156 0 0       0 croak 'Wrong number of arguments for bge()' unless @_ == 1;
2157              
2158 0         0 my $cmp = $self -> bcmp(shift);
2159 0   0     0 return defined($cmp) && $cmp >= 0;
2160             }
2161              
2162             ##############################################################################
2163             # output conversion
2164              
2165             sub numify {
2166             # convert 17/8 => float (aka 2.125)
2167 20 50   20 1 89 my ($self, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_);
2168              
2169             # Non-finite number.
2170              
2171 20 100       53 if ($x -> is_nan()) {
2172 1         14 require Math::Complex;
2173 1         3 my $inf = $Math::Complex::Inf;
2174 1         4 return $inf - $inf;
2175             }
2176              
2177 19 100       125 if ($x -> is_inf()) {
2178 2         30 require Math::Complex;
2179 2         6 my $inf = $Math::Complex::Inf;
2180 2 100       15 return $x -> is_negative() ? -$inf : $inf;
2181             }
2182              
2183             # Finite number.
2184              
2185             my $abs = $LIB->_is_one($x->{_d})
2186             ? $LIB->_num($x->{_n})
2187             : Math::BigFloat -> new($LIB->_str($x->{_n}))
2188 17 100       128 -> bdiv($LIB->_str($x->{_d}))
2189             -> bstr();
2190 17 100       7220 return $x->{sign} eq '-' ? 0 - $abs : 0 + $abs;
2191             }
2192              
2193             sub as_int {
2194 883 50   883 1 19676 my ($class, $x) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_);
2195              
2196 883 50       1351 return $x -> copy() if $x -> isa("Math::BigInt");
2197              
2198             # disable upgrading and downgrading
2199              
2200 883         4511 require Math::BigInt;
2201 883         2157 my $upg = Math::BigInt -> upgrade();
2202 883         6797 my $dng = Math::BigInt -> downgrade();
2203 883         7061 Math::BigInt -> upgrade(undef);
2204 883         6725 Math::BigInt -> downgrade(undef);
2205              
2206 883         6015 my $y;
2207 883 100       1529 if ($x -> is_inf()) {
    100          
2208 4         41 $y = Math::BigInt -> binf($x->sign());
2209             } elsif ($x -> is_nan()) {
2210 2         22 $y = Math::BigInt -> bnan();
2211             } else {
2212 877         10372 my $int = $LIB -> _div($LIB -> _copy($x->{_n}), $x->{_d}); # 22/7 => 3
2213 877         11840 $y = Math::BigInt -> new($LIB -> _str($int));
2214 877 100       57940 $y = $y -> bneg() if $x -> is_neg();
2215             }
2216              
2217             # reset upgrading and downgrading
2218              
2219 883         24542 Math::BigInt -> upgrade($upg);
2220 883         7275 Math::BigInt -> downgrade($dng);
2221              
2222 883         7029 return $y;
2223             }
2224              
2225             sub as_float {
2226 3 50   3 1 29 my ($class, $x, @r) = ref($_[0]) ? (ref($_[0]), @_) : objectify(1, @_);
2227              
2228 3 50       10 return $x -> copy() if $x -> isa("Math::BigFloat");
2229              
2230             # disable upgrading and downgrading
2231              
2232 3         24 require Math::BigFloat;
2233 3         13 my $upg = Math::BigFloat -> upgrade();
2234 3         37 my $dng = Math::BigFloat -> downgrade();
2235 3         33 Math::BigFloat -> upgrade(undef);
2236 3         26 Math::BigFloat -> downgrade(undef);
2237              
2238 3         24 my $y;
2239 3 50       7 if ($x -> is_inf()) {
    50          
2240 0         0 $y = Math::BigFloat -> binf($x->sign());
2241             } elsif ($x -> is_nan()) {
2242 0         0 $y = Math::BigFloat -> bnan();
2243             } else {
2244 3         42 $y = Math::BigFloat -> new($LIB -> _str($x->{_n}));
2245 3         235 $y -> {sign} = $x -> {sign};
2246 3 100       10 unless ($LIB -> _is_one($x->{_d})) {
2247 2         13 my $xd = Math::BigFloat -> new($LIB -> _str($x->{_d}));
2248 2         126 $y -> bdiv($xd, @r);
2249             }
2250             }
2251              
2252             # reset upgrading and downgrading
2253              
2254 3         1362 Math::BigFloat -> upgrade($upg);
2255 3         28 Math::BigFloat -> downgrade($dng);
2256              
2257 3         24 return $y;
2258             }
2259              
2260             sub as_bin {
2261 2 50   2 1 1380 my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_);
2262              
2263 2 50       7 return $x unless $x->is_int();
2264              
2265 2         19 my $s = $x->{sign};
2266 2 50       8 $s = '' if $s eq '+';
2267 2         7 $s . $LIB->_as_bin($x->{_n});
2268             }
2269              
2270             sub as_hex {
2271 2 50   2 1 18 my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_);
2272              
2273 2 50       8 return $x unless $x->is_int();
2274              
2275 2 50       17 my $s = $x->{sign}; $s = '' if $s eq '+';
  2         7  
2276 2         8 $s . $LIB->_as_hex($x->{_n});
2277             }
2278              
2279             sub as_oct {
2280 2 50   2 1 1111 my ($class, $x) = ref($_[0]) ? (undef, $_[0]) : objectify(1, @_);
2281              
2282 2 50       7 return $x unless $x->is_int();
2283              
2284 2 50       18 my $s = $x->{sign}; $s = '' if $s eq '+';
  2         10  
2285 2         7 $s . $LIB->_as_oct($x->{_n});
2286             }
2287              
2288             ##############################################################################
2289              
2290             sub from_hex {
2291 3     3 1 1391 my $class = shift;
2292              
2293             # The relationship should probably go the otherway, i.e, that new() calls
2294             # from_hex(). Fixme!
2295 3         11 my ($x, @r) = @_;
2296 3         16 $x =~ s|^\s*(?:0?[Xx]_*)?|0x|;
2297 3         16 $class->new($x, @r);
2298             }
2299              
2300             sub from_bin {
2301 3     3 1 2055 my $class = shift;
2302              
2303             # The relationship should probably go the otherway, i.e, that new() calls
2304             # from_bin(). Fixme!
2305 3         7 my ($x, @r) = @_;
2306 3         19 $x =~ s|^\s*(?:0?[Bb]_*)?|0b|;
2307 3         11 $class->new($x, @r);
2308             }
2309              
2310             sub from_oct {
2311 5     5 1 1971 my $class = shift;
2312              
2313             # Why is this different from from_hex() and from_bin()? Fixme!
2314 5         9 my @parts;
2315 5         11 for my $c (@_) {
2316 5         22 push @parts, Math::BigInt->from_oct($c);
2317             }
2318 5         2069 $class->new (@parts);
2319             }
2320              
2321             ##############################################################################
2322             # import
2323              
2324             sub import {
2325 19     19   1164 my $class = shift;
2326 19         31 my @a; # unrecognized arguments
2327 19         30 my $lib_param = '';
2328 19         30 my $lib_value = '';
2329              
2330 19         81 while (@_) {
2331 4         8 my $param = shift;
2332              
2333             # Enable overloading of constants.
2334              
2335 4 100       19 if ($param eq ':constant') {
2336             overload::constant
2337              
2338             integer => sub {
2339 7     7   21 $class -> new(shift);
2340             },
2341              
2342             float => sub {
2343 7     7   25 $class -> new(shift);
2344             },
2345              
2346             binary => sub {
2347             # E.g., a literal 0377 shall result in an object whose value
2348             # is decimal 255, but new("0377") returns decimal 377.
2349 8 100   8   1612 return $class -> from_oct($_[0]) if $_[0] =~ /^0_*[0-7]/;
2350 6         21 $class -> new(shift);
2351 1         7 };
2352 1         52 next;
2353             }
2354              
2355             # Upgrading.
2356              
2357 3 50       7 if ($param eq 'upgrade') {
2358 0         0 $class -> upgrade(shift);
2359 0         0 next;
2360             }
2361              
2362             # Downgrading.
2363              
2364 3 100       16 if ($param eq 'downgrade') {
2365 1         10 $class -> downgrade(shift);
2366 1         17 next;
2367             }
2368              
2369             # Accuracy.
2370              
2371 2 50       13 if ($param eq 'accuracy') {
2372 0         0 $class -> accuracy(shift);
2373 0         0 next;
2374             }
2375              
2376             # Precision.
2377              
2378 2 50       5 if ($param eq 'precision') {
2379 0         0 $class -> precision(shift);
2380 0         0 next;
2381             }
2382              
2383             # Rounding mode.
2384              
2385 2 50       5 if ($param eq 'round_mode') {
2386 0         0 $class -> round_mode(shift);
2387 0         0 next;
2388             }
2389              
2390             # Backend library.
2391              
2392 2 50       18 if ($param =~ /^(lib|try|only)\z/) {
2393             # alternative library
2394 2         5 $lib_param = $param; # "lib", "try", or "only"
2395 2         3 $lib_value = shift;
2396 2         8 next;
2397             }
2398              
2399 0 0       0 if ($param eq 'with') {
2400             # alternative class for our private parts()
2401             # XXX: no longer supported
2402             # $LIB = shift() || 'Calc';
2403             # carp "'with' is no longer supported, use 'lib', 'try', or 'only'";
2404 0         0 shift;
2405 0         0 next;
2406             }
2407              
2408             # Unrecognized parameter.
2409              
2410 0         0 push @a, $param;
2411             }
2412              
2413 19         119 require Math::BigInt;
2414              
2415 19         44 my @import = ('objectify');
2416 19 100       79 push @import, $lib_param, $lib_value if $lib_param ne '';
2417 19         111 Math::BigInt -> import(@import);
2418              
2419             # find out which one was actually loaded
2420 19         324009 $LIB = Math::BigInt -> config("lib");
2421              
2422             # any non :constant stuff is handled by Exporter (loaded by parent class)
2423             # even if @_ is empty, to give it a chance
2424 19         1201 $class->SUPER::import(@a); # for subclasses
2425 19         17921 $class->export_to_level(1, $class, @a); # need this, too
2426             }
2427              
2428             1;
2429              
2430             __END__