← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
  Run on Tue Oct 15 11:58:52 2013
Reported on Tue Oct 15 12:02:16 2013

Filename/usr/share/perl/5.10/Math/BigInt.pm
StatementsExecuted 217 statements in 18.6ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
111298µs13.8msMath::BigInt::::importMath::BigInt::import
111147µs260µsMath::BigInt::::newMath::BigInt::new
11186µs305µsMath::BigInt::::BEGIN@44Math::BigInt::BEGIN@44
11142µs65µsMath::BigInt::::_splitMath::BigInt::_split
11135µs35µsMath::BigInt::::BEGIN@19Math::BigInt::BEGIN@19
11128µs28µsMath::BigInt::::TIESCALARMath::BigInt::TIESCALAR
11126µs53µsMath::BigInt::::BEGIN@193Math::BigInt::BEGIN@193
11125µs44µsMath::BigInt::::BEGIN@207Math::BigInt::BEGIN@207
77125µs25µsMath::BigInt::::CORE:matchMath::BigInt::CORE:match (opcode)
11121µs21µsMath::BigInt::::roundMath::BigInt::round
11121µs33µsMath::BigInt::::round_modeMath::BigInt::round_mode
11120µs46µsMath::BigInt::::BEGIN@690Math::BigInt::BEGIN@690
11119µs47µsMath::BigInt::::BEGIN@2526Math::BigInt::BEGIN@2526
11118µs35µsMath::BigInt::::bstrMath::BigInt::bstr
55118µs18µsMath::BigInt::::CORE:substMath::BigInt::CORE:subst (opcode)
11115µs31µsMath::BigInt::::BEGIN@879Math::BigInt::BEGIN@879
11115µs31µsMath::BigInt::::BEGIN@377Math::BigInt::BEGIN@377
11112µs28µsMath::BigInt::::BEGIN@2920Math::BigInt::BEGIN@2920
11111µs27µsMath::BigInt::::BEGIN@447Math::BigInt::BEGIN@447
11111µs27µsMath::BigInt::::BEGIN@656Math::BigInt::BEGIN@656
11111µs126µsMath::BigInt::::BEGIN@28Math::BigInt::BEGIN@28
11110µs24µsMath::BigInt::::BEGIN@548Math::BigInt::BEGIN@548
11110µs24µsMath::BigInt::::BEGIN@943Math::BigInt::BEGIN@943
11110µs25µsMath::BigInt::::BEGIN@336Math::BigInt::BEGIN@336
11110µs23µsMath::BigInt::::BEGIN@470Math::BigInt::BEGIN@470
11110µs13µsMath::BigInt::::BEGIN@30Math::BigInt::BEGIN@30
11110µs21µsMath::BigInt::::BEGIN@239Math::BigInt::BEGIN@239
1119µs22µsMath::BigInt::::BEGIN@278Math::BigInt::BEGIN@278
1119µs23µsMath::BigInt::::BEGIN@225Math::BigInt::BEGIN@225
1119µs21µsMath::BigInt::::BEGIN@253Math::BigInt::BEGIN@253
1119µs42µsMath::BigInt::::STOREMath::BigInt::STORE
2114µs4µsMath::BigInt::::CORE:substcontMath::BigInt::CORE:substcont (opcode)
0000s0sMath::BigInt::::FETCHMath::BigInt::FETCH
0000s0sMath::BigInt::::__ANON__[:100]Math::BigInt::__ANON__[:100]
0000s0sMath::BigInt::::__ANON__[:101]Math::BigInt::__ANON__[:101]
0000s0sMath::BigInt::::__ANON__[:106]Math::BigInt::__ANON__[:106]
0000s0sMath::BigInt::::__ANON__[:107]Math::BigInt::__ANON__[:107]
0000s0sMath::BigInt::::__ANON__[:108]Math::BigInt::__ANON__[:108]
0000s0sMath::BigInt::::__ANON__[:112]Math::BigInt::__ANON__[:112]
0000s0sMath::BigInt::::__ANON__[:115]Math::BigInt::__ANON__[:115]
0000s0sMath::BigInt::::__ANON__[:118]Math::BigInt::__ANON__[:118]
0000s0sMath::BigInt::::__ANON__[:121]Math::BigInt::__ANON__[:121]
0000s0sMath::BigInt::::__ANON__[:124]Math::BigInt::__ANON__[:124]
0000s0sMath::BigInt::::__ANON__[:127]Math::BigInt::__ANON__[:127]
0000s0sMath::BigInt::::__ANON__[:130]Math::BigInt::__ANON__[:130]
0000s0sMath::BigInt::::__ANON__[:133]Math::BigInt::__ANON__[:133]
0000s0sMath::BigInt::::__ANON__[:137]Math::BigInt::__ANON__[:137]
0000s0sMath::BigInt::::__ANON__[:138]Math::BigInt::__ANON__[:138]
0000s0sMath::BigInt::::__ANON__[:147]Math::BigInt::__ANON__[:147]
0000s0sMath::BigInt::::__ANON__[:151]Math::BigInt::__ANON__[:151]
0000s0sMath::BigInt::::__ANON__[:152]Math::BigInt::__ANON__[:152]
0000s0sMath::BigInt::::__ANON__[:2605]Math::BigInt::__ANON__[:2605]
0000s0sMath::BigInt::::__ANON__[:2606]Math::BigInt::__ANON__[:2606]
0000s0sMath::BigInt::::__ANON__[:44]Math::BigInt::__ANON__[:44]
0000s0sMath::BigInt::::__ANON__[:49]Math::BigInt::__ANON__[:49]
0000s0sMath::BigInt::::__ANON__[:50]Math::BigInt::__ANON__[:50]
0000s0sMath::BigInt::::__ANON__[:51]Math::BigInt::__ANON__[:51]
0000s0sMath::BigInt::::__ANON__[:52]Math::BigInt::__ANON__[:52]
0000s0sMath::BigInt::::__ANON__[:53]Math::BigInt::__ANON__[:53]
0000s0sMath::BigInt::::__ANON__[:54]Math::BigInt::__ANON__[:54]
0000s0sMath::BigInt::::__ANON__[:55]Math::BigInt::__ANON__[:55]
0000s0sMath::BigInt::::__ANON__[:56]Math::BigInt::__ANON__[:56]
0000s0sMath::BigInt::::__ANON__[:58]Math::BigInt::__ANON__[:58]
0000s0sMath::BigInt::::__ANON__[:59]Math::BigInt::__ANON__[:59]
0000s0sMath::BigInt::::__ANON__[:60]Math::BigInt::__ANON__[:60]
0000s0sMath::BigInt::::__ANON__[:70]Math::BigInt::__ANON__[:70]
0000s0sMath::BigInt::::__ANON__[:78]Math::BigInt::__ANON__[:78]
0000s0sMath::BigInt::::__ANON__[:82]Math::BigInt::__ANON__[:82]
0000s0sMath::BigInt::::__ANON__[:84]Math::BigInt::__ANON__[:84]
0000s0sMath::BigInt::::__ANON__[:85]Math::BigInt::__ANON__[:85]
0000s0sMath::BigInt::::__ANON__[:88]Math::BigInt::__ANON__[:88]
0000s0sMath::BigInt::::__ANON__[:95]Math::BigInt::__ANON__[:95]
0000s0sMath::BigInt::::__ANON__[:96]Math::BigInt::__ANON__[:96]
0000s0sMath::BigInt::::__ANON__[:97]Math::BigInt::__ANON__[:97]
0000s0sMath::BigInt::::__ANON__[:98]Math::BigInt::__ANON__[:98]
0000s0sMath::BigInt::::__ANON__[:99]Math::BigInt::__ANON__[:99]
0000s0sMath::BigInt::::__from_binMath::BigInt::__from_bin
0000s0sMath::BigInt::::__from_hexMath::BigInt::__from_hex
0000s0sMath::BigInt::::__lcmMath::BigInt::__lcm
0000s0sMath::BigInt::::_div_infMath::BigInt::_div_inf
0000s0sMath::BigInt::::_find_round_parametersMath::BigInt::_find_round_parameters
0000s0sMath::BigInt::::_register_callbackMath::BigInt::_register_callback
0000s0sMath::BigInt::::_scale_aMath::BigInt::_scale_a
0000s0sMath::BigInt::::_scale_pMath::BigInt::_scale_p
0000s0sMath::BigInt::::_scan_for_nonzeroMath::BigInt::_scan_for_nonzero
0000s0sMath::BigInt::::_trailing_zerosMath::BigInt::_trailing_zeros
0000s0sMath::BigInt::::accuracyMath::BigInt::accuracy
0000s0sMath::BigInt::::as_binMath::BigInt::as_bin
0000s0sMath::BigInt::::as_hexMath::BigInt::as_hex
0000s0sMath::BigInt::::as_numberMath::BigInt::as_number
0000s0sMath::BigInt::::as_octMath::BigInt::as_oct
0000s0sMath::BigInt::::babsMath::BigInt::babs
0000s0sMath::BigInt::::bacmpMath::BigInt::bacmp
0000s0sMath::BigInt::::baddMath::BigInt::badd
0000s0sMath::BigInt::::bandMath::BigInt::band
0000s0sMath::BigInt::::batanMath::BigInt::batan
0000s0sMath::BigInt::::batan2Math::BigInt::batan2
0000s0sMath::BigInt::::bceilMath::BigInt::bceil
0000s0sMath::BigInt::::bcmpMath::BigInt::bcmp
0000s0sMath::BigInt::::bcosMath::BigInt::bcos
0000s0sMath::BigInt::::bdecMath::BigInt::bdec
0000s0sMath::BigInt::::bdivMath::BigInt::bdiv
0000s0sMath::BigInt::::bexpMath::BigInt::bexp
0000s0sMath::BigInt::::bfacMath::BigInt::bfac
0000s0sMath::BigInt::::bfloorMath::BigInt::bfloor
0000s0sMath::BigInt::::bfroundMath::BigInt::bfround
0000s0sMath::BigInt::::bgcdMath::BigInt::bgcd
0000s0sMath::BigInt::::bincMath::BigInt::binc
0000s0sMath::BigInt::::binfMath::BigInt::binf
0000s0sMath::BigInt::::biorMath::BigInt::bior
0000s0sMath::BigInt::::blcmMath::BigInt::blcm
0000s0sMath::BigInt::::blogMath::BigInt::blog
0000s0sMath::BigInt::::blsftMath::BigInt::blsft
0000s0sMath::BigInt::::bmodMath::BigInt::bmod
0000s0sMath::BigInt::::bmodinvMath::BigInt::bmodinv
0000s0sMath::BigInt::::bmodpowMath::BigInt::bmodpow
0000s0sMath::BigInt::::bmulMath::BigInt::bmul
0000s0sMath::BigInt::::bmuladdMath::BigInt::bmuladd
0000s0sMath::BigInt::::bnanMath::BigInt::bnan
0000s0sMath::BigInt::::bnegMath::BigInt::bneg
0000s0sMath::BigInt::::bnokMath::BigInt::bnok
0000s0sMath::BigInt::::bnormMath::BigInt::bnorm
0000s0sMath::BigInt::::bnotMath::BigInt::bnot
0000s0sMath::BigInt::::boneMath::BigInt::bone
0000s0sMath::BigInt::::bpiMath::BigInt::bpi
0000s0sMath::BigInt::::bpowMath::BigInt::bpow
0000s0sMath::BigInt::::brootMath::BigInt::broot
0000s0sMath::BigInt::::broundMath::BigInt::bround
0000s0sMath::BigInt::::brsftMath::BigInt::brsft
0000s0sMath::BigInt::::bsinMath::BigInt::bsin
0000s0sMath::BigInt::::bsqrtMath::BigInt::bsqrt
0000s0sMath::BigInt::::bsstrMath::BigInt::bsstr
0000s0sMath::BigInt::::bsubMath::BigInt::bsub
0000s0sMath::BigInt::::bxorMath::BigInt::bxor
0000s0sMath::BigInt::::bzeroMath::BigInt::bzero
0000s0sMath::BigInt::::configMath::BigInt::config
0000s0sMath::BigInt::::copyMath::BigInt::copy
0000s0sMath::BigInt::::digitMath::BigInt::digit
0000s0sMath::BigInt::::div_scaleMath::BigInt::div_scale
0000s0sMath::BigInt::::downgradeMath::BigInt::downgrade
0000s0sMath::BigInt::::exponentMath::BigInt::exponent
0000s0sMath::BigInt::::from_binMath::BigInt::from_bin
0000s0sMath::BigInt::::from_hexMath::BigInt::from_hex
0000s0sMath::BigInt::::from_octMath::BigInt::from_oct
0000s0sMath::BigInt::::froundMath::BigInt::fround
0000s0sMath::BigInt::::is_evenMath::BigInt::is_even
0000s0sMath::BigInt::::is_infMath::BigInt::is_inf
0000s0sMath::BigInt::::is_intMath::BigInt::is_int
0000s0sMath::BigInt::::is_nanMath::BigInt::is_nan
0000s0sMath::BigInt::::is_negativeMath::BigInt::is_negative
0000s0sMath::BigInt::::is_oddMath::BigInt::is_odd
0000s0sMath::BigInt::::is_oneMath::BigInt::is_one
0000s0sMath::BigInt::::is_positiveMath::BigInt::is_positive
0000s0sMath::BigInt::::is_zeroMath::BigInt::is_zero
0000s0sMath::BigInt::::lengthMath::BigInt::length
0000s0sMath::BigInt::::mantissaMath::BigInt::mantissa
0000s0sMath::BigInt::::numifyMath::BigInt::numify
0000s0sMath::BigInt::::objectifyMath::BigInt::objectify
0000s0sMath::BigInt::::partsMath::BigInt::parts
0000s0sMath::BigInt::::precisionMath::BigInt::precision
0000s0sMath::BigInt::::signMath::BigInt::sign
0000s0sMath::BigInt::::upgradeMath::BigInt::upgrade
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package Math::BigInt;
2
3#
4# "Mike had an infinite amount to do and a negative amount of time in which
5# to do it." - Before and After
6#
7
8# The following hash values are used:
9# value: unsigned int with actual value (as a Math::BigInt::Calc or similiar)
10# sign : +,-,NaN,+inf,-inf
11# _a : accuracy
12# _p : precision
13# _f : flags, used by MBF to flag parts of a float as untouchable
14
15# Remember not to take shortcuts ala $xs = $x->{value}; $CALC->foo($xs); since
16# underlying lib might change the reference!
17
1811µsmy $class = "Math::BigInt";
19385µs135µs
# spent 35µs within Math::BigInt::BEGIN@19 which was called: # once (35µs+0s) by Library::CallNumber::LC::BEGIN@5 at line 19
use 5.006;
# spent 35µs making 1 call to Math::BigInt::BEGIN@19
20
211600ns$VERSION = '1.89';
22
23115µs@ISA = qw(Exporter);
2411µs@EXPORT_OK = qw(objectify bgcd blcm);
25
26# _trap_inf and _trap_nan are internal and should never be accessed from the
27# outside
2816µs1116µs
# spent 126µs (11+116) within Math::BigInt::BEGIN@28 which was called: # once (11µs+116µs) by Library::CallNumber::LC::BEGIN@5 at line 29
use vars qw/$round_mode $accuracy $precision $div_scale $rnd_mode
# spent 116µs making 1 call to vars::import
29226µs1126µs $upgrade $downgrade $_trap_nan $_trap_inf/;
# spent 126µs making 1 call to Math::BigInt::BEGIN@28
3031.22ms216µs
# spent 13µs (10+3) within Math::BigInt::BEGIN@30 which was called: # once (10µs+3µs) by Library::CallNumber::LC::BEGIN@5 at line 30
use strict;
# spent 13µs making 1 call to Math::BigInt::BEGIN@30 # spent 3µs making 1 call to strict::import
31
32# Inside overload, the first arg is always an object. If the original code had
33# it reversed (like $x = 2 * $y), then the third paramater is true.
34# In some cases (like add, $x = $x + 2 is the same as $x = 2 + $x) this makes
35# no difference, but in some cases it does.
36
37# For overloaded ops with only one argument we simple use $_[0]->copy() to
38# preserve the argument.
39
40# Thus inheritance of overload operators becomes possible and transparent for
41# our subclasses without the need to repeat the entire overload section there.
42
43use overload
44
# spent 305µs (86+219) within Math::BigInt::BEGIN@44 which was called: # once (86µs+219µs) by Library::CallNumber::LC::BEGIN@5 at line 153
'=' => sub { $_[0]->copy(); },
45
46# some shortcuts for speed (assumes that reversed order of arguments is routed
47# to normal '+' and we thus can always modify first arg. If this is changed,
48# this breaks and must be adjusted.)
49'+=' => sub { $_[0]->badd($_[1]); },
50'-=' => sub { $_[0]->bsub($_[1]); },
51'*=' => sub { $_[0]->bmul($_[1]); },
52'/=' => sub { scalar $_[0]->bdiv($_[1]); },
53'%=' => sub { $_[0]->bmod($_[1]); },
54'^=' => sub { $_[0]->bxor($_[1]); },
55'&=' => sub { $_[0]->band($_[1]); },
56'|=' => sub { $_[0]->bior($_[1]); },
57
58'**=' => sub { $_[0]->bpow($_[1]); },
59'<<=' => sub { $_[0]->blsft($_[1]); },
60'>>=' => sub { $_[0]->brsft($_[1]); },
61
62# not supported by Perl yet
63'..' => \&_pointpoint,
64
65'<=>' => sub { my $rc = $_[2] ?
66 ref($_[0])->bcmp($_[1],$_[0]) :
67 $_[0]->bcmp($_[1]);
68 $rc = 1 unless defined $rc;
69 $rc <=> 0;
70 },
71# we need '>=' to get things like "1 >= NaN" right:
72'>=' => sub { my $rc = $_[2] ?
73 ref($_[0])->bcmp($_[1],$_[0]) :
74 $_[0]->bcmp($_[1]);
75 # if there was a NaN involved, return false
76 return '' unless defined $rc;
77 $rc >= 0;
78 },
79'cmp' => sub {
80 $_[2] ?
81 "$_[1]" cmp $_[0]->bstr() :
82 $_[0]->bstr() cmp "$_[1]" },
83
84'cos' => sub { $_[0]->copy->bcos(); },
85'sin' => sub { $_[0]->copy->bsin(); },
86'atan2' => sub { $_[2] ?
87 ref($_[0])->new($_[1])->batan2($_[0]) :
88 $_[0]->copy()->batan2($_[1]) },
89
90# are not yet overloadable
91#'hex' => sub { print "hex"; $_[0]; },
92#'oct' => sub { print "oct"; $_[0]; },
93
94# log(N) is log(N, e), where e is Euler's number
95'log' => sub { $_[0]->copy()->blog($_[1], undef); },
96'exp' => sub { $_[0]->copy()->bexp($_[1]); },
97'int' => sub { $_[0]->copy(); },
98'neg' => sub { $_[0]->copy()->bneg(); },
99'abs' => sub { $_[0]->copy()->babs(); },
100'sqrt' => sub { $_[0]->copy()->bsqrt(); },
101'~' => sub { $_[0]->copy()->bnot(); },
102
103# for subtract it's a bit tricky to not modify b: b-a => -a+b
104'-' => sub { my $c = $_[0]->copy; $_[2] ?
105 $c->bneg()->badd( $_[1]) :
106 $c->bsub( $_[1]) },
107'+' => sub { $_[0]->copy()->badd($_[1]); },
108'*' => sub { $_[0]->copy()->bmul($_[1]); },
109
110'/' => sub {
111 $_[2] ? ref($_[0])->new($_[1])->bdiv($_[0]) : $_[0]->copy->bdiv($_[1]);
112 },
113'%' => sub {
114 $_[2] ? ref($_[0])->new($_[1])->bmod($_[0]) : $_[0]->copy->bmod($_[1]);
115 },
116'**' => sub {
117 $_[2] ? ref($_[0])->new($_[1])->bpow($_[0]) : $_[0]->copy->bpow($_[1]);
118 },
119'<<' => sub {
120 $_[2] ? ref($_[0])->new($_[1])->blsft($_[0]) : $_[0]->copy->blsft($_[1]);
121 },
122'>>' => sub {
123 $_[2] ? ref($_[0])->new($_[1])->brsft($_[0]) : $_[0]->copy->brsft($_[1]);
124 },
125'&' => sub {
126 $_[2] ? ref($_[0])->new($_[1])->band($_[0]) : $_[0]->copy->band($_[1]);
127 },
128'|' => sub {
129 $_[2] ? ref($_[0])->new($_[1])->bior($_[0]) : $_[0]->copy->bior($_[1]);
130 },
131'^' => sub {
132 $_[2] ? ref($_[0])->new($_[1])->bxor($_[0]) : $_[0]->copy->bxor($_[1]);
133 },
134
135# can modify arg of ++ and --, so avoid a copy() for speed, but don't
136# use $_[0]->bone(), it would modify $_[0] to be 1!
137'++' => sub { $_[0]->binc() },
138'--' => sub { $_[0]->bdec() },
139
140# if overloaded, O(1) instead of O(N) and twice as fast for small numbers
141'bool' => sub {
142 # this kludge is needed for perl prior 5.6.0 since returning 0 here fails :-/
143 # v5.6.1 dumps on this: return !$_[0]->is_zero() || undef; :-(
144 my $t = undef;
145 $t = 1 if !$_[0]->is_zero();
146 $t;
147 },
148
149# the original qw() does not work with the TIESCALAR below, why?
150# Order of arguments unsignificant
151'""' => sub { $_[0]->bstr(); },
152'0+' => sub { $_[0]->numify(); }
1533305µs2524µs;
# spent 305µs making 1 call to Math::BigInt::BEGIN@44 # spent 219µs making 1 call to overload::import
154
155##############################################################################
156# global constants, flags and accessory
157
158# These vars are public, but their direct usage is not recommended, use the
159# accessor methods instead
160
1611700ns$round_mode = 'even'; # one of 'even', 'odd', '+inf', '-inf', 'zero', 'trunc' or 'common'
1621800ns$accuracy = undef;
1631200ns$precision = undef;
1641400ns$div_scale = 40;
165
1661200ns$upgrade = undef; # default is no upgrade
1671400ns$downgrade = undef; # default is no downgrade
168
169# These are internally, and not to be used from the outside at all
170
1711300ns$_trap_nan = 0; # are NaNs ok? set w/ config()
1721400ns$_trap_inf = 0; # are infs ok? set w/ config()
1731300nsmy $nan = 'NaN'; # constants for easier life
174
1751400nsmy $CALC = 'Math::BigInt::FastCalc'; # module to do the low level math
176 # default is FastCalc.pm
1771300nsmy $IMPORT = 0; # was import() called yet?
178 # used to make require work
1791200nsmy %WARN; # warn only once for low-level libs
1801100nsmy %CAN; # cache for $CALC->can(...)
1811200nsmy %CALLBACKS; # callbacks to notify on lib loads
1821300nsmy $EMU_LIB = 'Math/BigInt/CalcEmu.pm'; # emulate low-level math
183
184##############################################################################
185# the old code had $rnd_mode, so we need to support it, too
186
18717µs142µs$rnd_mode = 'even';
# spent 42µs making 1 call to Math::BigInt::STORE
188233µs
# spent 28µs within Math::BigInt::TIESCALAR which was called: # once (28µs+0s) by Math::BigInt::BEGIN@193 at line 195
sub TIESCALAR { my ($class) = @_; bless \$round_mode, $class; }
189sub FETCH { return $round_mode; }
19017µs133µs
# spent 42µs (9+33) within Math::BigInt::STORE which was called: # once (9µs+33µs) by Library::CallNumber::LC::BEGIN@5 at line 187
sub STORE { $rnd_mode = $_[0]->round_mode($_[1]); }
# spent 33µs making 1 call to Math::BigInt::round_mode
191
192BEGIN
193
# spent 53µs (26+28) within Math::BigInt::BEGIN@193 which was called: # once (26µs+28µs) by Library::CallNumber::LC::BEGIN@5 at line 201
{
194 # tie to enable $rnd_mode to work transparently
19515µs128µs tie $rnd_mode, 'Math::BigInt';
# spent 28µs making 1 call to Math::BigInt::TIESCALAR
196
197 # set up some handy alias names
19815µs *as_int = \&as_number;
19913µs *is_pos = \&is_positive;
20017µs *is_neg = \&is_negative;
201132µs153µs }
# spent 53µs making 1 call to Math::BigInt::BEGIN@193
202
203##############################################################################
204
205sub round_mode
206
# spent 33µs (21+12) within Math::BigInt::round_mode which was called: # once (21µs+12µs) by Math::BigInt::STORE at line 190
{
2073158µs264µs
# spent 44µs (25+19) within Math::BigInt::BEGIN@207 which was called: # once (25µs+19µs) by Library::CallNumber::LC::BEGIN@5 at line 207
no strict 'refs';
# spent 44µs making 1 call to Math::BigInt::BEGIN@207 # spent 20µs making 1 call to strict::unimport
208 # make Class->round_mode() work
20911µs my $self = shift;
21012µs my $class = ref($self) || $self || __PACKAGE__;
21111µs if (defined $_[0])
212 {
2131500ns my $m = shift;
214121µs112µs if ($m !~ /^(even|odd|\+inf|\-inf|zero|trunc|common)$/)
# spent 12µs making 1 call to Math::BigInt::CORE:match
215 {
216 require Carp; Carp::croak ("Unknown round mode '$m'");
217 }
218110µs return ${"${class}::round_mode"} = $m;
219 }
220 ${"${class}::round_mode"};
221 }
222
223sub upgrade
224 {
225389µs236µs
# spent 23µs (9+13) within Math::BigInt::BEGIN@225 which was called: # once (9µs+13µs) by Library::CallNumber::LC::BEGIN@5 at line 225
no strict 'refs';
# spent 23µs making 1 call to Math::BigInt::BEGIN@225 # spent 13µs making 1 call to strict::unimport
226 # make Class->upgrade() work
227 my $self = shift;
228 my $class = ref($self) || $self || __PACKAGE__;
229 # need to set new value?
230 if (@_ > 0)
231 {
232 return ${"${class}::upgrade"} = $_[0];
233 }
234 ${"${class}::upgrade"};
235 }
236
237sub downgrade
238 {
239394µs233µs
# spent 21µs (10+12) within Math::BigInt::BEGIN@239 which was called: # once (10µs+12µs) by Library::CallNumber::LC::BEGIN@5 at line 239
no strict 'refs';
# spent 21µs making 1 call to Math::BigInt::BEGIN@239 # spent 12µs making 1 call to strict::unimport
240 # make Class->downgrade() work
241 my $self = shift;
242 my $class = ref($self) || $self || __PACKAGE__;
243 # need to set new value?
244 if (@_ > 0)
245 {
246 return ${"${class}::downgrade"} = $_[0];
247 }
248 ${"${class}::downgrade"};
249 }
250
251sub div_scale
252 {
2533141µs234µs
# spent 21µs (9+12) within Math::BigInt::BEGIN@253 which was called: # once (9µs+12µs) by Library::CallNumber::LC::BEGIN@5 at line 253
no strict 'refs';
# spent 21µs making 1 call to Math::BigInt::BEGIN@253 # spent 12µs making 1 call to strict::unimport
254 # make Class->div_scale() work
255 my $self = shift;
256 my $class = ref($self) || $self || __PACKAGE__;
257 if (defined $_[0])
258 {
259 if ($_[0] < 0)
260 {
261 require Carp; Carp::croak ('div_scale must be greater than zero');
262 }
263 ${"${class}::div_scale"} = $_[0];
264 }
265 ${"${class}::div_scale"};
266 }
267
268sub accuracy
269 {
270 # $x->accuracy($a); ref($x) $a
271 # $x->accuracy(); ref($x)
272 # Class->accuracy(); class
273 # Class->accuracy($a); class $a
274
275 my $x = shift;
276 my $class = ref($x) || $x || __PACKAGE__;
277
2783350µs235µs
# spent 22µs (9+13) within Math::BigInt::BEGIN@278 which was called: # once (9µs+13µs) by Library::CallNumber::LC::BEGIN@5 at line 278
no strict 'refs';
# spent 22µs making 1 call to Math::BigInt::BEGIN@278 # spent 13µs making 1 call to strict::unimport
279 # need to set new value?
280 if (@_ > 0)
281 {
282 my $a = shift;
283 # convert objects to scalars to avoid deep recursion. If object doesn't
284 # have numify(), then hopefully it will have overloading for int() and
285 # boolean test without wandering into a deep recursion path...
286 $a = $a->numify() if ref($a) && $a->can('numify');
287
288 if (defined $a)
289 {
290 # also croak on non-numerical
291 if (!$a || $a <= 0)
292 {
293 require Carp;
294 Carp::croak ('Argument to accuracy must be greater than zero');
295 }
296 if (int($a) != $a)
297 {
298 require Carp;
299 Carp::croak ('Argument to accuracy must be an integer');
300 }
301 }
302 if (ref($x))
303 {
304 # $object->accuracy() or fallback to global
305 $x->bround($a) if $a; # not for undef, 0
306 $x->{_a} = $a; # set/overwrite, even if not rounded
307 delete $x->{_p}; # clear P
308 $a = ${"${class}::accuracy"} unless defined $a; # proper return value
309 }
310 else
311 {
312 ${"${class}::accuracy"} = $a; # set global A
313 ${"${class}::precision"} = undef; # clear global P
314 }
315 return $a; # shortcut
316 }
317
318 my $a;
319 # $object->accuracy() or fallback to global
320 $a = $x->{_a} if ref($x);
321 # but don't return global undef, when $x's accuracy is 0!
322 $a = ${"${class}::accuracy"} if !defined $a;
323 $a;
324 }
325
326sub precision
327 {
328 # $x->precision($p); ref($x) $p
329 # $x->precision(); ref($x)
330 # Class->precision(); class
331 # Class->precision($p); class $p
332
333 my $x = shift;
334 my $class = ref($x) || $x || __PACKAGE__;
335
3363236µs239µs
# spent 25µs (10+14) within Math::BigInt::BEGIN@336 which was called: # once (10µs+14µs) by Library::CallNumber::LC::BEGIN@5 at line 336
no strict 'refs';
# spent 25µs making 1 call to Math::BigInt::BEGIN@336 # spent 14µs making 1 call to strict::unimport
337 if (@_ > 0)
338 {
339 my $p = shift;
340 # convert objects to scalars to avoid deep recursion. If object doesn't
341 # have numify(), then hopefully it will have overloading for int() and
342 # boolean test without wandering into a deep recursion path...
343 $p = $p->numify() if ref($p) && $p->can('numify');
344 if ((defined $p) && (int($p) != $p))
345 {
346 require Carp; Carp::croak ('Argument to precision must be an integer');
347 }
348 if (ref($x))
349 {
350 # $object->precision() or fallback to global
351 $x->bfround($p) if $p; # not for undef, 0
352 $x->{_p} = $p; # set/overwrite, even if not rounded
353 delete $x->{_a}; # clear A
354 $p = ${"${class}::precision"} unless defined $p; # proper return value
355 }
356 else
357 {
358 ${"${class}::precision"} = $p; # set global P
359 ${"${class}::accuracy"} = undef; # clear global A
360 }
361 return $p; # shortcut
362 }
363
364 my $p;
365 # $object->precision() or fallback to global
366 $p = $x->{_p} if ref($x);
367 # but don't return global undef, when $x's precision is 0!
368 $p = ${"${class}::precision"} if !defined $p;
369 $p;
370 }
371
372sub config
373 {
374 # return (or set) configuration data as hash ref
375 my $class = shift || 'Math::BigInt';
376
3773412µs247µs
# spent 31µs (15+16) within Math::BigInt::BEGIN@377 which was called: # once (15µs+16µs) by Library::CallNumber::LC::BEGIN@5 at line 377
no strict 'refs';
# spent 31µs making 1 call to Math::BigInt::BEGIN@377 # spent 16µs making 1 call to strict::unimport
378 if (@_ > 1 || (@_ == 1 && (ref($_[0]) eq 'HASH')))
379 {
380 # try to set given options as arguments from hash
381
382 my $args = $_[0];
383 if (ref($args) ne 'HASH')
384 {
385 $args = { @_ };
386 }
387 # these values can be "set"
388 my $set_args = {};
389 foreach my $key (
390 qw/trap_inf trap_nan
391 upgrade downgrade precision accuracy round_mode div_scale/
392 )
393 {
394 $set_args->{$key} = $args->{$key} if exists $args->{$key};
395 delete $args->{$key};
396 }
397 if (keys %$args > 0)
398 {
399 require Carp;
400 Carp::croak ("Illegal key(s) '",
401 join("','",keys %$args),"' passed to $class\->config()");
402 }
403 foreach my $key (keys %$set_args)
404 {
405 if ($key =~ /^trap_(inf|nan)\z/)
406 {
407 ${"${class}::_trap_$1"} = ($set_args->{"trap_$1"} ? 1 : 0);
408 next;
409 }
410 # use a call instead of just setting the $variable to check argument
411 $class->$key($set_args->{$key});
412 }
413 }
414
415 # now return actual configuration
416
417 my $cfg = {
418 lib => $CALC,
419 lib_version => ${"${CALC}::VERSION"},
420 class => $class,
421 trap_nan => ${"${class}::_trap_nan"},
422 trap_inf => ${"${class}::_trap_inf"},
423 version => ${"${class}::VERSION"},
424 };
425 foreach my $key (qw/
426 upgrade downgrade precision accuracy round_mode div_scale
427 /)
428 {
429 $cfg->{$key} = ${"${class}::$key"};
430 };
431 if (@_ == 1 && (ref($_[0]) ne 'HASH'))
432 {
433 # calls of the style config('lib') return just this value
434 return $cfg->{$_[0]};
435 }
436 $cfg;
437 }
438
439sub _scale_a
440 {
441 # select accuracy parameter based on precedence,
442 # used by bround() and bfround(), may return undef for scale (means no op)
443 my ($x,$scale,$mode) = @_;
444
445 $scale = $x->{_a} unless defined $scale;
446
4473127µs242µs
# spent 27µs (11+15) within Math::BigInt::BEGIN@447 which was called: # once (11µs+15µs) by Library::CallNumber::LC::BEGIN@5 at line 447
no strict 'refs';
# spent 27µs making 1 call to Math::BigInt::BEGIN@447 # spent 16µs making 1 call to strict::unimport
448 my $class = ref($x);
449
450 $scale = ${ $class . '::accuracy' } unless defined $scale;
451 $mode = ${ $class . '::round_mode' } unless defined $mode;
452
453 if (defined $scale)
454 {
455 $scale = $scale->can('numify') ? $scale->numify() : "$scale" if ref($scale);
456 $scale = int($scale);
457 }
458
459 ($scale,$mode);
460 }
461
462sub _scale_p
463 {
464 # select precision parameter based on precedence,
465 # used by bround() and bfround(), may return undef for scale (means no op)
466 my ($x,$scale,$mode) = @_;
467
468 $scale = $x->{_p} unless defined $scale;
469
4703383µs235µs
# spent 23µs (10+13) within Math::BigInt::BEGIN@470 which was called: # once (10µs+13µs) by Library::CallNumber::LC::BEGIN@5 at line 470
no strict 'refs';
# spent 23µs making 1 call to Math::BigInt::BEGIN@470 # spent 13µs making 1 call to strict::unimport
471 my $class = ref($x);
472
473 $scale = ${ $class . '::precision' } unless defined $scale;
474 $mode = ${ $class . '::round_mode' } unless defined $mode;
475
476 if (defined $scale)
477 {
478 $scale = $scale->can('numify') ? $scale->numify() : "$scale" if ref($scale);
479 $scale = int($scale);
480 }
481
482 ($scale,$mode);
483 }
484
485##############################################################################
486# constructors
487
488sub copy
489 {
490 # if two arguments, the first one is the class to "swallow" subclasses
491 if (@_ > 1)
492 {
493 my $self = bless {
494 sign => $_[1]->{sign},
495 value => $CALC->_copy($_[1]->{value}),
496 }, $_[0] if @_ > 1;
497
498 $self->{_a} = $_[1]->{_a} if defined $_[1]->{_a};
499 $self->{_p} = $_[1]->{_p} if defined $_[1]->{_p};
500 return $self;
501 }
502
503 my $self = bless {
504 sign => $_[0]->{sign},
505 value => $CALC->_copy($_[0]->{value}),
506 }, ref($_[0]);
507
508 $self->{_a} = $_[0]->{_a} if defined $_[0]->{_a};
509 $self->{_p} = $_[0]->{_p} if defined $_[0]->{_p};
510 $self;
511 }
512
513sub new
514
# spent 260µs (147+113) within Math::BigInt::new which was called: # once (147µs+113µs) by C4::ClassSortRoutine::LCC::BEGIN@23 at line 344 of Library/CallNumber/LC.pm
{
515 # create a new BigInt object from a string or another BigInt object.
516 # see hash keys documented at top
517
518 # the argument could be an object, so avoid ||, && etc on it, this would
519 # cause costly overloaded code to be called. The only allowed ops are
520 # ref() and defined.
521
52213µs my ($class,$wanted,$a,$p,$r) = @_;
523
524 # avoid numify-calls by not using || on $wanted!
52511µs return $class->bzero($a,$p) if !defined $wanted; # default to 0
52611µs return $class->copy($wanted,$a,$p,$r)
527 if ref($wanted) && $wanted->isa($class); # MBI or subclass
528
52911µs $class->import() if $IMPORT == 0; # make require work
530
531167µs my $self = bless {}, $class;
532
533 # shortcut for "normal" numbers
534110µs14µs if ((!ref $wanted) && ($wanted =~ /^([+-]?)[1-9][0-9]*\z/))
# spent 4µs making 1 call to Math::BigInt::CORE:match
535 {
536 $self->{sign} = $1 || '+';
537
538 if ($wanted =~ /^[+-]/)
539 {
540 # remove sign without touching wanted to make it work with constants
541 my $t = $wanted; $t =~ s/^[+-]//;
542 $self->{value} = $CALC->_new($t);
543 }
544 else
545 {
546 $self->{value} = $CALC->_new($wanted);
547 }
5483622µs238µs
# spent 24µs (10+14) within Math::BigInt::BEGIN@548 which was called: # once (10µs+14µs) by Library::CallNumber::LC::BEGIN@5 at line 548
no strict 'refs';
# spent 24µs making 1 call to Math::BigInt::BEGIN@548 # spent 14µs making 1 call to strict::unimport
549 if ( (defined $a) || (defined $p)
550 || (defined ${"${class}::precision"})
551 || (defined ${"${class}::accuracy"})
552 )
553 {
554 $self->round($a,$p,$r) unless (@_ == 4 && !defined $a && !defined $p);
555 }
556 return $self;
557 }
558
559 # handle '+inf', '-inf' first
56018µs1700ns if ($wanted =~ /^[+-]?inf\z/)
# spent 700ns making 1 call to Math::BigInt::CORE:match
561 {
562 $self->{sign} = $wanted; # set a default sign for bstr()
563 return $self->binf($wanted);
564 }
565 # split str in m mantissa, e exponent, i integer, f fraction, v value, s sign
56618µs165µs my ($mis,$miv,$mfv,$es,$ev) = _split($wanted);
# spent 65µs making 1 call to Math::BigInt::_split
56712µs if (!ref $mis)
568 {
569 if ($_trap_nan)
570 {
571 require Carp; Carp::croak("$wanted is not a number in $class");
572 }
573 $self->{value} = $CALC->_zero();
574 $self->{sign} = $nan;
575 return $self;
576 }
5771900ns if (!ref $miv)
578 {
579 # _from_hex or _from_bin
580 $self->{value} = $mis->{value};
581 $self->{sign} = $mis->{sign};
582 return $self; # throw away $mis
583 }
584 # make integer from mantissa by adjusting exp, then convert to bigint
58514µs $self->{sign} = $$mis; # store sign
586121µs111µs $self->{value} = $CALC->_zero(); # for all the NaN cases
# spent 11µs making 1 call to Math::BigInt::FastCalc::_zero
58714µs my $e = int("$$es$$ev"); # exponent (avoid recursion)
58811µs if ($e > 0)
589 {
590 my $diff = $e - CORE::length($$mfv);
591 if ($diff < 0) # Not integer
592 {
593 if ($_trap_nan)
594 {
595 require Carp; Carp::croak("$wanted not an integer in $class");
596 }
597 #print "NOI 1\n";
598 return $upgrade->new($wanted,$a,$p,$r) if defined $upgrade;
599 $self->{sign} = $nan;
600 }
601 else # diff >= 0
602 {
603 # adjust fraction and add it to value
604 #print "diff > 0 $$miv\n";
605 $$miv = $$miv . ($$mfv . '0' x $diff);
606 }
607 }
608 else
609 {
61012µs if ($$mfv ne '') # e <= 0
611 {
612 # fraction and negative/zero E => NOI
613 if ($_trap_nan)
614 {
615 require Carp; Carp::croak("$wanted not an integer in $class");
616 }
617 #print "NOI 2 \$\$mfv '$$mfv'\n";
618 return $upgrade->new($wanted,$a,$p,$r) if defined $upgrade;
619 $self->{sign} = $nan;
620 }
621 elsif ($e < 0)
622 {
623 # xE-y, and empty mfv
624 #print "xE-y\n";
625 $e = abs($e);
626 if ($$miv !~ s/0{$e}$//) # can strip so many zero's?
627 {
628 if ($_trap_nan)
629 {
630 require Carp; Carp::croak("$wanted not an integer in $class");
631 }
632 #print "NOI 3\n";
633 return $upgrade->new($wanted,$a,$p,$r) if defined $upgrade;
634 $self->{sign} = $nan;
635 }
636 }
637 }
63812µs $self->{sign} = '+' if $$miv eq '0'; # normalize -0 => +0
639121µs210µs $self->{value} = $CALC->_new($$miv) if $self->{sign} =~ /^[+-]$/;
# spent 8µs making 1 call to Math::BigInt::FastCalc::_new # spent 2µs making 1 call to Math::BigInt::CORE:match
640 # if any of the globals is set, use them to round and store them inside $self
641 # do not round for new($x,undef,undef) since that is used by MBF to signal
642 # no rounding
64315µs121µs $self->round($a,$p,$r) unless @_ == 4 && !defined $a && !defined $p;
# spent 21µs making 1 call to Math::BigInt::round
64415µs $self;
645 }
646
647sub bnan
648 {
649 # create a bigint 'NaN', if given a BigInt, set it to 'NaN'
650 my $self = shift;
651 $self = $class if !defined $self;
652 if (!ref($self))
653 {
654 my $c = $self; $self = {}; bless $self, $c;
655 }
6563293µs243µs
# spent 27µs (11+16) within Math::BigInt::BEGIN@656 which was called: # once (11µs+16µs) by Library::CallNumber::LC::BEGIN@5 at line 656
no strict 'refs';
# spent 27µs making 1 call to Math::BigInt::BEGIN@656 # spent 16µs making 1 call to strict::unimport
657 if (${"${class}::_trap_nan"})
658 {
659 require Carp;
660 Carp::croak ("Tried to set $self to NaN in $class\::bnan()");
661 }
662 $self->import() if $IMPORT == 0; # make require work
663 return if $self->modify('bnan');
664 if ($self->can('_bnan'))
665 {
666 # use subclass to initialize
667 $self->_bnan();
668 }
669 else
670 {
671 # otherwise do our own thing
672 $self->{value} = $CALC->_zero();
673 }
674 $self->{sign} = $nan;
675 delete $self->{_a}; delete $self->{_p}; # rounding NaN is silly
676 $self;
677 }
678
679sub binf
680 {
681 # create a bigint '+-inf', if given a BigInt, set it to '+-inf'
682 # the sign is either '+', or if given, used from there
683 my $self = shift;
684 my $sign = shift; $sign = '+' if !defined $sign || $sign !~ /^-(inf)?$/;
685 $self = $class if !defined $self;
686 if (!ref($self))
687 {
688 my $c = $self; $self = {}; bless $self, $c;
689 }
69031.01ms271µs
# spent 46µs (20+25) within Math::BigInt::BEGIN@690 which was called: # once (20µs+25µs) by Library::CallNumber::LC::BEGIN@5 at line 690
no strict 'refs';
# spent 46µs making 1 call to Math::BigInt::BEGIN@690 # spent 25µs making 1 call to strict::unimport
691 if (${"${class}::_trap_inf"})
692 {
693 require Carp;
694 Carp::croak ("Tried to set $self to +-inf in $class\::binf()");
695 }
696 $self->import() if $IMPORT == 0; # make require work
697 return if $self->modify('binf');
698 if ($self->can('_binf'))
699 {
700 # use subclass to initialize
701 $self->_binf();
702 }
703 else
704 {
705 # otherwise do our own thing
706 $self->{value} = $CALC->_zero();
707 }
708 $sign = $sign . 'inf' if $sign !~ /inf$/; # - => -inf
709 $self->{sign} = $sign;
710 ($self->{_a},$self->{_p}) = @_; # take over requested rounding
711 $self;
712 }
713
714sub bzero
715 {
716 # create a bigint '+0', if given a BigInt, set it to 0
717 my $self = shift;
718 $self = __PACKAGE__ if !defined $self;
719
720 if (!ref($self))
721 {
722 my $c = $self; $self = {}; bless $self, $c;
723 }
724 $self->import() if $IMPORT == 0; # make require work
725 return if $self->modify('bzero');
726
727 if ($self->can('_bzero'))
728 {
729 # use subclass to initialize
730 $self->_bzero();
731 }
732 else
733 {
734 # otherwise do our own thing
735 $self->{value} = $CALC->_zero();
736 }
737 $self->{sign} = '+';
738 if (@_ > 0)
739 {
740 if (@_ > 3)
741 {
742 # call like: $x->bzero($a,$p,$r,$y);
743 ($self,$self->{_a},$self->{_p}) = $self->_find_round_parameters(@_);
744 }
745 else
746 {
747 $self->{_a} = $_[0]
748 if ( (!defined $self->{_a}) || (defined $_[0] && $_[0] > $self->{_a}));
749 $self->{_p} = $_[1]
750 if ( (!defined $self->{_p}) || (defined $_[1] && $_[1] > $self->{_p}));
751 }
752 }
753 $self;
754 }
755
756sub bone
757 {
758 # create a bigint '+1' (or -1 if given sign '-'),
759 # if given a BigInt, set it to +1 or -1, respectively
760 my $self = shift;
761 my $sign = shift; $sign = '+' if !defined $sign || $sign ne '-';
762 $self = $class if !defined $self;
763
764 if (!ref($self))
765 {
766 my $c = $self; $self = {}; bless $self, $c;
767 }
768 $self->import() if $IMPORT == 0; # make require work
769 return if $self->modify('bone');
770
771 if ($self->can('_bone'))
772 {
773 # use subclass to initialize
774 $self->_bone();
775 }
776 else
777 {
778 # otherwise do our own thing
779 $self->{value} = $CALC->_one();
780 }
781 $self->{sign} = $sign;
782 if (@_ > 0)
783 {
784 if (@_ > 3)
785 {
786 # call like: $x->bone($sign,$a,$p,$r,$y);
787 ($self,$self->{_a},$self->{_p}) = $self->_find_round_parameters(@_);
788 }
789 else
790 {
791 # call like: $x->bone($sign,$a,$p,$r);
792 $self->{_a} = $_[0]
793 if ( (!defined $self->{_a}) || (defined $_[0] && $_[0] > $self->{_a}));
794 $self->{_p} = $_[1]
795 if ( (!defined $self->{_p}) || (defined $_[1] && $_[1] > $self->{_p}));
796 }
797 }
798 $self;
799 }
800
801##############################################################################
802# string conversation
803
804sub bsstr
805 {
806 # (ref to BFLOAT or num_str ) return num_str
807 # Convert number from internal format to scientific string format.
808 # internal format is always normalized (no leading zeros, "-0E0" => "+0E0")
809 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
810
811 if ($x->{sign} !~ /^[+-]$/)
812 {
813 return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN
814 return 'inf'; # +inf
815 }
816 my ($m,$e) = $x->parts();
817 #$m->bstr() . 'e+' . $e->bstr(); # e can only be positive in BigInt
818 # 'e+' because E can only be positive in BigInt
819 $m->bstr() . 'e+' . $CALC->_str($e->{value});
820 }
821
822sub bstr
823
# spent 35µs (18+16) within Math::BigInt::bstr which was called: # once (18µs+16µs) by C4::ClassSortRoutine::LCC::BEGIN@23 at line 345 of Library/CallNumber/LC.pm
{
824 # make a string from bigint object
82513µs my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
826
82716µs11µs if ($x->{sign} !~ /^[+-]$/)
# spent 1µs making 1 call to Math::BigInt::CORE:match
828 {
829 return $x->{sign} unless $x->{sign} eq '+inf'; # -inf, NaN
830 return 'inf'; # +inf
831 }
83222µs my $es = ''; $es = $x->{sign} if $x->{sign} eq '-';
83319µs115µs $es.$CALC->_str($x->{value});
# spent 15µs making 1 call to Math::BigInt::Calc::_str
834 }
835
836sub numify
837 {
838 # Make a "normal" scalar from a BigInt object
839 my $x = shift; $x = $class->new($x) unless ref $x;
840
841 return $x->bstr() if $x->{sign} !~ /^[+-]$/;
842 my $num = $CALC->_num($x->{value});
843 return -$num if $x->{sign} eq '-';
844 $num;
845 }
846
847##############################################################################
848# public stuff (usually prefixed with "b")
849
850sub sign
851 {
852 # return the sign of the number: +/-/-inf/+inf/NaN
853 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
854
855 $x->{sign};
856 }
857
858sub _find_round_parameters
859 {
860 # After any operation or when calling round(), the result is rounded by
861 # regarding the A & P from arguments, local parameters, or globals.
862
863 # !!!!!!! If you change this, remember to change round(), too! !!!!!!!!!!
864
865 # This procedure finds the round parameters, but it is for speed reasons
866 # duplicated in round. Otherwise, it is tested by the testsuite and used
867 # by fdiv().
868
869 # returns ($self) or ($self,$a,$p,$r) - sets $self to NaN of both A and P
870 # were requested/defined (locally or globally or both)
871
872 my ($self,$a,$p,$r,@args) = @_;
873 # $a accuracy, if given by caller
874 # $p precision, if given by caller
875 # $r round_mode, if given by caller
876 # @args all 'other' arguments (0 for unary, 1 for binary ops)
877
878 my $c = ref($self); # find out class of argument(s)
8793327µs247µs
# spent 31µs (15+16) within Math::BigInt::BEGIN@879 which was called: # once (15µs+16µs) by Library::CallNumber::LC::BEGIN@5 at line 879
no strict 'refs';
# spent 31µs making 1 call to Math::BigInt::BEGIN@879 # spent 16µs making 1 call to strict::unimport
880
881 # convert to normal scalar for speed and correctness in inner parts
882 $a = $a->can('numify') ? $a->numify() : "$a" if defined $a && ref($a);
883 $p = $p->can('numify') ? $p->numify() : "$p" if defined $p && ref($p);
884
885 # now pick $a or $p, but only if we have got "arguments"
886 if (!defined $a)
887 {
888 foreach ($self,@args)
889 {
890 # take the defined one, or if both defined, the one that is smaller
891 $a = $_->{_a} if (defined $_->{_a}) && (!defined $a || $_->{_a} < $a);
892 }
893 }
894 if (!defined $p)
895 {
896 # even if $a is defined, take $p, to signal error for both defined
897 foreach ($self,@args)
898 {
899 # take the defined one, or if both defined, the one that is bigger
900 # -2 > -3, and 3 > 2
901 $p = $_->{_p} if (defined $_->{_p}) && (!defined $p || $_->{_p} > $p);
902 }
903 }
904 # if still none defined, use globals (#2)
905 $a = ${"$c\::accuracy"} unless defined $a;
906 $p = ${"$c\::precision"} unless defined $p;
907
908 # A == 0 is useless, so undef it to signal no rounding
909 $a = undef if defined $a && $a == 0;
910
911 # no rounding today?
912 return ($self) unless defined $a || defined $p; # early out
913
914 # set A and set P is an fatal error
915 return ($self->bnan()) if defined $a && defined $p; # error
916
917 $r = ${"$c\::round_mode"} unless defined $r;
918 if ($r !~ /^(even|odd|\+inf|\-inf|zero|trunc|common)$/)
919 {
920 require Carp; Carp::croak ("Unknown round mode '$r'");
921 }
922
923 $a = int($a) if defined $a;
924 $p = int($p) if defined $p;
925
926 ($self,$a,$p,$r);
927 }
928
929sub round
930
# spent 21µs within Math::BigInt::round which was called: # once (21µs+0s) by Math::BigInt::new at line 643
{
931 # Round $self according to given parameters, or given second argument's
932 # parameters or global defaults
933
934 # for speed reasons, _find_round_parameters is embeded here:
935
93612µs my ($self,$a,$p,$r,@args) = @_;
937 # $a accuracy, if given by caller
938 # $p precision, if given by caller
939 # $r round_mode, if given by caller
940 # @args all 'other' arguments (0 for unary, 1 for binary ops)
941
94211µs my $c = ref($self); # find out class of argument(s)
94338.84ms237µs
# spent 24µs (10+13) within Math::BigInt::BEGIN@943 which was called: # once (10µs+13µs) by Library::CallNumber::LC::BEGIN@5 at line 943
no strict 'refs';
# spent 24µs making 1 call to Math::BigInt::BEGIN@943 # spent 13µs making 1 call to strict::unimport
944
945 # now pick $a or $p, but only if we have got "arguments"
94613µs if (!defined $a)
947 {
948 foreach ($self,@args)
949 {
950 # take the defined one, or if both defined, the one that is smaller
95112µs $a = $_->{_a} if (defined $_->{_a}) && (!defined $a || $_->{_a} < $a);
952 }
953 }
95412µs if (!defined $p)
955 {
956 # even if $a is defined, take $p, to signal error for both defined
957 foreach ($self,@args)
958 {
959 # take the defined one, or if both defined, the one that is bigger
960 # -2 > -3, and 3 > 2
96111µs $p = $_->{_p} if (defined $_->{_p}) && (!defined $p || $_->{_p} > $p);
962 }
963 }
964 # if still none defined, use globals (#2)
96514µs $a = ${"$c\::accuracy"} unless defined $a;
96612µs $p = ${"$c\::precision"} unless defined $p;
967
968 # A == 0 is useless, so undef it to signal no rounding
9691400ns $a = undef if defined $a && $a == 0;
970
971 # no rounding today?
97215µs return $self unless defined $a || defined $p; # early out
973
974 # set A and set P is an fatal error
975 return $self->bnan() if defined $a && defined $p;
976
977 $r = ${"$c\::round_mode"} unless defined $r;
978 if ($r !~ /^(even|odd|\+inf|\-inf|zero|trunc|common)$/)
979 {
980 require Carp; Carp::croak ("Unknown round mode '$r'");
981 }
982
983 # now round, by calling either fround or ffround:
984 if (defined $a)
985 {
986 $self->bround(int($a),$r) if !defined $self->{_a} || $self->{_a} >= $a;
987 }
988 else # both can't be undefined due to early out
989 {
990 $self->bfround(int($p),$r) if !defined $self->{_p} || $self->{_p} <= $p;
991 }
992 # bround() or bfround() already callled bnorm() if nec.
993 $self;
994 }
995
996sub bnorm
997 {
998 # (numstr or BINT) return BINT
999 # Normalize number -- no-op here
1000 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
1001 $x;
1002 }
1003
1004sub babs
1005 {
1006 # (BINT or num_str) return BINT
1007 # make number absolute, or return absolute BINT from string
1008 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
1009
1010 return $x if $x->modify('babs');
1011 # post-normalized abs for internal use (does nothing for NaN)
1012 $x->{sign} =~ s/^-/+/;
1013 $x;
1014 }
1015
1016sub bneg
1017 {
1018 # (BINT or num_str) return BINT
1019 # negate number or make a negated number from string
1020 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
1021
1022 return $x if $x->modify('bneg');
1023
1024 # for +0 dont negate (to have always normalized +0). Does nothing for 'NaN'
1025 $x->{sign} =~ tr/+-/-+/ unless ($x->{sign} eq '+' && $CALC->_is_zero($x->{value}));
1026 $x;
1027 }
1028
1029sub bcmp
1030 {
1031 # Compares 2 values. Returns one of undef, <0, =0, >0. (suitable for sort)
1032 # (BINT or num_str, BINT or num_str) return cond_code
1033
1034 # set up parameters
1035 my ($self,$x,$y) = (ref($_[0]),@_);
1036
1037 # objectify is costly, so avoid it
1038 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
1039 {
1040 ($self,$x,$y) = objectify(2,@_);
1041 }
1042
1043 return $upgrade->bcmp($x,$y) if defined $upgrade &&
1044 ((!$x->isa($self)) || (!$y->isa($self)));
1045
1046 if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
1047 {
1048 # handle +-inf and NaN
1049 return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
1050 return 0 if $x->{sign} eq $y->{sign} && $x->{sign} =~ /^[+-]inf$/;
1051 return +1 if $x->{sign} eq '+inf';
1052 return -1 if $x->{sign} eq '-inf';
1053 return -1 if $y->{sign} eq '+inf';
1054 return +1;
1055 }
1056 # check sign for speed first
1057 return 1 if $x->{sign} eq '+' && $y->{sign} eq '-'; # does also 0 <=> -y
1058 return -1 if $x->{sign} eq '-' && $y->{sign} eq '+'; # does also -x <=> 0
1059
1060 # have same sign, so compare absolute values. Don't make tests for zero here
1061 # because it's actually slower than testin in Calc (especially w/ Pari et al)
1062
1063 # post-normalized compare for internal use (honors signs)
1064 if ($x->{sign} eq '+')
1065 {
1066 # $x and $y both > 0
1067 return $CALC->_acmp($x->{value},$y->{value});
1068 }
1069
1070 # $x && $y both < 0
1071 $CALC->_acmp($y->{value},$x->{value}); # swaped acmp (lib returns 0,1,-1)
1072 }
1073
1074sub bacmp
1075 {
1076 # Compares 2 values, ignoring their signs.
1077 # Returns one of undef, <0, =0, >0. (suitable for sort)
1078 # (BINT, BINT) return cond_code
1079
1080 # set up parameters
1081 my ($self,$x,$y) = (ref($_[0]),@_);
1082 # objectify is costly, so avoid it
1083 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
1084 {
1085 ($self,$x,$y) = objectify(2,@_);
1086 }
1087
1088 return $upgrade->bacmp($x,$y) if defined $upgrade &&
1089 ((!$x->isa($self)) || (!$y->isa($self)));
1090
1091 if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
1092 {
1093 # handle +-inf and NaN
1094 return undef if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
1095 return 0 if $x->{sign} =~ /^[+-]inf$/ && $y->{sign} =~ /^[+-]inf$/;
1096 return 1 if $x->{sign} =~ /^[+-]inf$/ && $y->{sign} !~ /^[+-]inf$/;
1097 return -1;
1098 }
1099 $CALC->_acmp($x->{value},$y->{value}); # lib does only 0,1,-1
1100 }
1101
1102sub badd
1103 {
1104 # add second arg (BINT or string) to first (BINT) (modifies first)
1105 # return result as BINT
1106
1107 # set up parameters
1108 my ($self,$x,$y,@r) = (ref($_[0]),@_);
1109 # objectify is costly, so avoid it
1110 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
1111 {
1112 ($self,$x,$y,@r) = objectify(2,@_);
1113 }
1114
1115 return $x if $x->modify('badd');
1116 return $upgrade->badd($upgrade->new($x),$upgrade->new($y),@r) if defined $upgrade &&
1117 ((!$x->isa($self)) || (!$y->isa($self)));
1118
1119 $r[3] = $y; # no push!
1120 # inf and NaN handling
1121 if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/))
1122 {
1123 # NaN first
1124 return $x->bnan() if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
1125 # inf handling
1126 if (($x->{sign} =~ /^[+-]inf$/) && ($y->{sign} =~ /^[+-]inf$/))
1127 {
1128 # +inf++inf or -inf+-inf => same, rest is NaN
1129 return $x if $x->{sign} eq $y->{sign};
1130 return $x->bnan();
1131 }
1132 # +-inf + something => +inf
1133 # something +-inf => +-inf
1134 $x->{sign} = $y->{sign}, return $x if $y->{sign} =~ /^[+-]inf$/;
1135 return $x;
1136 }
1137
1138 my ($sx, $sy) = ( $x->{sign}, $y->{sign} ); # get signs
1139
1140 if ($sx eq $sy)
1141 {
1142 $x->{value} = $CALC->_add($x->{value},$y->{value}); # same sign, abs add
1143 }
1144 else
1145 {
1146 my $a = $CALC->_acmp ($y->{value},$x->{value}); # absolute compare
1147 if ($a > 0)
1148 {
1149 $x->{value} = $CALC->_sub($y->{value},$x->{value},1); # abs sub w/ swap
1150 $x->{sign} = $sy;
1151 }
1152 elsif ($a == 0)
1153 {
1154 # speedup, if equal, set result to 0
1155 $x->{value} = $CALC->_zero();
1156 $x->{sign} = '+';
1157 }
1158 else # a < 0
1159 {
1160 $x->{value} = $CALC->_sub($x->{value}, $y->{value}); # abs sub
1161 }
1162 }
1163 $x->round(@r);
1164 }
1165
1166sub bsub
1167 {
1168 # (BINT or num_str, BINT or num_str) return BINT
1169 # subtract second arg from first, modify first
1170
1171 # set up parameters
1172 my ($self,$x,$y,@r) = (ref($_[0]),@_);
1173
1174 # objectify is costly, so avoid it
1175 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
1176 {
1177 ($self,$x,$y,@r) = objectify(2,@_);
1178 }
1179
1180 return $x if $x->modify('bsub');
1181
1182 return $upgrade->new($x)->bsub($upgrade->new($y),@r) if defined $upgrade &&
1183 ((!$x->isa($self)) || (!$y->isa($self)));
1184
1185 return $x->round(@r) if $y->is_zero();
1186
1187 # To correctly handle the lone special case $x->bsub($x), we note the sign
1188 # of $x, then flip the sign from $y, and if the sign of $x did change, too,
1189 # then we caught the special case:
1190 my $xsign = $x->{sign};
1191 $y->{sign} =~ tr/+\-/-+/; # does nothing for NaN
1192 if ($xsign ne $x->{sign})
1193 {
1194 # special case of $x->bsub($x) results in 0
1195 return $x->bzero(@r) if $xsign =~ /^[+-]$/;
1196 return $x->bnan(); # NaN, -inf, +inf
1197 }
1198 $x->badd($y,@r); # badd does not leave internal zeros
1199 $y->{sign} =~ tr/+\-/-+/; # refix $y (does nothing for NaN)
1200 $x; # already rounded by badd() or no round nec.
1201 }
1202
1203sub binc
1204 {
1205 # increment arg by one
1206 my ($self,$x,$a,$p,$r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
1207 return $x if $x->modify('binc');
1208
1209 if ($x->{sign} eq '+')
1210 {
1211 $x->{value} = $CALC->_inc($x->{value});
1212 return $x->round($a,$p,$r);
1213 }
1214 elsif ($x->{sign} eq '-')
1215 {
1216 $x->{value} = $CALC->_dec($x->{value});
1217 $x->{sign} = '+' if $CALC->_is_zero($x->{value}); # -1 +1 => -0 => +0
1218 return $x->round($a,$p,$r);
1219 }
1220 # inf, nan handling etc
1221 $x->badd($self->bone(),$a,$p,$r); # badd does round
1222 }
1223
1224sub bdec
1225 {
1226 # decrement arg by one
1227 my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
1228 return $x if $x->modify('bdec');
1229
1230 if ($x->{sign} eq '-')
1231 {
1232 # x already < 0
1233 $x->{value} = $CALC->_inc($x->{value});
1234 }
1235 else
1236 {
1237 return $x->badd($self->bone('-'),@r) unless $x->{sign} eq '+'; # inf or NaN
1238 # >= 0
1239 if ($CALC->_is_zero($x->{value}))
1240 {
1241 # == 0
1242 $x->{value} = $CALC->_one(); $x->{sign} = '-'; # 0 => -1
1243 }
1244 else
1245 {
1246 # > 0
1247 $x->{value} = $CALC->_dec($x->{value});
1248 }
1249 }
1250 $x->round(@r);
1251 }
1252
1253sub blog
1254 {
1255 # calculate $x = $a ** $base + $b and return $a (e.g. the log() to base
1256 # $base of $x)
1257
1258 # set up parameters
1259 my ($self,$x,$base,@r) = (undef,@_);
1260 # objectify is costly, so avoid it
1261 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
1262 {
1263 ($self,$x,$base,@r) = objectify(1,ref($x),@_);
1264 }
1265
1266 return $x if $x->modify('blog');
1267
1268 $base = $self->new($base) if defined $base && !ref $base;
1269
1270 # inf, -inf, NaN, <0 => NaN
1271 return $x->bnan()
1272 if $x->{sign} ne '+' || (defined $base && $base->{sign} ne '+');
1273
1274 return $upgrade->blog($upgrade->new($x),$base,@r) if
1275 defined $upgrade;
1276
1277 # fix for bug #24969:
1278 # the default base is e (Euler's number) which is not an integer
1279 if (!defined $base)
1280 {
1281 require Math::BigFloat;
1282 my $u = Math::BigFloat->blog(Math::BigFloat->new($x))->as_int();
1283 # modify $x in place
1284 $x->{value} = $u->{value};
1285 $x->{sign} = $u->{sign};
1286 return $x;
1287 }
1288
1289 my ($rc,$exact) = $CALC->_log_int($x->{value},$base->{value});
1290 return $x->bnan() unless defined $rc; # not possible to take log?
1291 $x->{value} = $rc;
1292 $x->round(@r);
1293 }
1294
1295sub bnok
1296 {
1297 # Calculate n over k (binomial coefficient or "choose" function) as integer.
1298 # set up parameters
1299 my ($self,$x,$y,@r) = (ref($_[0]),@_);
1300
1301 # objectify is costly, so avoid it
1302 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
1303 {
1304 ($self,$x,$y,@r) = objectify(2,@_);
1305 }
1306
1307 return $x if $x->modify('bnok');
1308 return $x->bnan() if $x->{sign} eq 'NaN' || $y->{sign} eq 'NaN';
1309 return $x->binf() if $x->{sign} eq '+inf';
1310
1311 # k > n or k < 0 => 0
1312 my $cmp = $x->bacmp($y);
1313 return $x->bzero() if $cmp < 0 || $y->{sign} =~ /^-/;
1314 # k == n => 1
1315 return $x->bone(@r) if $cmp == 0;
1316
1317 if ($CALC->can('_nok'))
1318 {
1319 $x->{value} = $CALC->_nok($x->{value},$y->{value});
1320 }
1321 else
1322 {
1323 # ( 7 ) 7! 7*6*5 * 4*3*2*1 7 * 6 * 5
1324 # ( - ) = --------- = --------------- = ---------
1325 # ( 3 ) 3! (7-3)! 3*2*1 * 4*3*2*1 3 * 2 * 1
1326
1327 # compute n - k + 2 (so we start with 5 in the example above)
1328 my $z = $x - $y;
1329 if (!$z->is_one())
1330 {
1331 $z->binc();
1332 my $r = $z->copy(); $z->binc();
1333 my $d = $self->new(2);
1334 while ($z->bacmp($x) <= 0) # f < x ?
1335 {
1336 $r->bmul($z); $r->bdiv($d);
1337 $z->binc(); $d->binc();
1338 }
1339 $x->{value} = $r->{value}; $x->{sign} = '+';
1340 }
1341 else { $x->bone(); }
1342 }
1343 $x->round(@r);
1344 }
1345
1346sub bexp
1347 {
1348 # Calculate e ** $x (Euler's number to the power of X), truncated to
1349 # an integer value.
1350 my ($self,$x,@r) = ref($_[0]) ? (ref($_[0]),@_) : objectify(1,@_);
1351 return $x if $x->modify('bexp');
1352
1353 # inf, -inf, NaN, <0 => NaN
1354 return $x->bnan() if $x->{sign} eq 'NaN';
1355 return $x->bone() if $x->is_zero();
1356 return $x if $x->{sign} eq '+inf';
1357 return $x->bzero() if $x->{sign} eq '-inf';
1358
1359 my $u;
1360 {
1361 # run through Math::BigFloat unless told otherwise
1362 require Math::BigFloat unless defined $upgrade;
1363 local $upgrade = 'Math::BigFloat' unless defined $upgrade;
1364 # calculate result, truncate it to integer
1365 $u = $upgrade->bexp($upgrade->new($x),@r);
1366 }
1367
1368 if (!defined $upgrade)
1369 {
1370 $u = $u->as_int();
1371 # modify $x in place
1372 $x->{value} = $u->{value};
1373 $x->round(@r);
1374 }
1375 else { $x = $u; }
1376 }
1377
1378sub blcm
1379 {
1380 # (BINT or num_str, BINT or num_str) return BINT
1381 # does not modify arguments, but returns new object
1382 # Lowest Common Multiplicator
1383
1384 my $y = shift; my ($x);
1385 if (ref($y))
1386 {
1387 $x = $y->copy();
1388 }
1389 else
1390 {
1391 $x = $class->new($y);
1392 }
1393 my $self = ref($x);
1394 while (@_)
1395 {
1396 my $y = shift; $y = $self->new($y) if !ref ($y);
1397 $x = __lcm($x,$y);
1398 }
1399 $x;
1400 }
1401
1402sub bgcd
1403 {
1404 # (BINT or num_str, BINT or num_str) return BINT
1405 # does not modify arguments, but returns new object
1406 # GCD -- Euclids algorithm, variant C (Knuth Vol 3, pg 341 ff)
1407
1408 my $y = shift;
1409 $y = $class->new($y) if !ref($y);
1410 my $self = ref($y);
1411 my $x = $y->copy()->babs(); # keep arguments
1412 return $x->bnan() if $x->{sign} !~ /^[+-]$/; # x NaN?
1413
1414 while (@_)
1415 {
1416 $y = shift; $y = $self->new($y) if !ref($y);
1417 return $x->bnan() if $y->{sign} !~ /^[+-]$/; # y NaN?
1418 $x->{value} = $CALC->_gcd($x->{value},$y->{value});
1419 last if $CALC->_is_one($x->{value});
1420 }
1421 $x;
1422 }
1423
1424sub bnot
1425 {
1426 # (num_str or BINT) return BINT
1427 # represent ~x as twos-complement number
1428 # we don't need $self, so undef instead of ref($_[0]) make it slightly faster
1429 my ($self,$x,$a,$p,$r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
1430
1431 return $x if $x->modify('bnot');
1432 $x->binc()->bneg(); # binc already does round
1433 }
1434
1435##############################################################################
1436# is_foo test routines
1437# we don't need $self, so undef instead of ref($_[0]) make it slightly faster
1438
1439sub is_zero
1440 {
1441 # return true if arg (BINT or num_str) is zero (array '+', '0')
1442 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
1443
1444 return 0 if $x->{sign} !~ /^\+$/; # -, NaN & +-inf aren't
1445 $CALC->_is_zero($x->{value});
1446 }
1447
1448sub is_nan
1449 {
1450 # return true if arg (BINT or num_str) is NaN
1451 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
1452
1453 $x->{sign} eq $nan ? 1 : 0;
1454 }
1455
1456sub is_inf
1457 {
1458 # return true if arg (BINT or num_str) is +-inf
1459 my ($self,$x,$sign) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
1460
1461 if (defined $sign)
1462 {
1463 $sign = '[+-]inf' if $sign eq ''; # +- doesn't matter, only that's inf
1464 $sign = "[$1]inf" if $sign =~ /^([+-])(inf)?$/; # extract '+' or '-'
1465 return $x->{sign} =~ /^$sign$/ ? 1 : 0;
1466 }
1467 $x->{sign} =~ /^[+-]inf$/ ? 1 : 0; # only +-inf is infinity
1468 }
1469
1470sub is_one
1471 {
1472 # return true if arg (BINT or num_str) is +1, or -1 if sign is given
1473 my ($self,$x,$sign) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
1474
1475 $sign = '+' if !defined $sign || $sign ne '-';
1476
1477 return 0 if $x->{sign} ne $sign; # -1 != +1, NaN, +-inf aren't either
1478 $CALC->_is_one($x->{value});
1479 }
1480
1481sub is_odd
1482 {
1483 # return true when arg (BINT or num_str) is odd, false for even
1484 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
1485
1486 return 0 if $x->{sign} !~ /^[+-]$/; # NaN & +-inf aren't
1487 $CALC->_is_odd($x->{value});
1488 }
1489
1490sub is_even
1491 {
1492 # return true when arg (BINT or num_str) is even, false for odd
1493 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
1494
1495 return 0 if $x->{sign} !~ /^[+-]$/; # NaN & +-inf aren't
1496 $CALC->_is_even($x->{value});
1497 }
1498
1499sub is_positive
1500 {
1501 # return true when arg (BINT or num_str) is positive (>= 0)
1502 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
1503
1504 return 1 if $x->{sign} eq '+inf'; # +inf is positive
1505
1506 # 0+ is neither positive nor negative
1507 ($x->{sign} eq '+' && !$x->is_zero()) ? 1 : 0;
1508 }
1509
1510sub is_negative
1511 {
1512 # return true when arg (BINT or num_str) is negative (< 0)
1513 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
1514
1515 $x->{sign} =~ /^-/ ? 1 : 0; # -inf is negative, but NaN is not
1516 }
1517
1518sub is_int
1519 {
1520 # return true when arg (BINT or num_str) is an integer
1521 # always true for BigInt, but different for BigFloats
1522 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
1523
1524 $x->{sign} =~ /^[+-]$/ ? 1 : 0; # inf/-inf/NaN aren't
1525 }
1526
1527###############################################################################
1528
1529sub bmul
1530 {
1531 # multiply the first number by the second number
1532 # (BINT or num_str, BINT or num_str) return BINT
1533
1534 # set up parameters
1535 my ($self,$x,$y,@r) = (ref($_[0]),@_);
1536 # objectify is costly, so avoid it
1537 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
1538 {
1539 ($self,$x,$y,@r) = objectify(2,@_);
1540 }
1541
1542 return $x if $x->modify('bmul');
1543
1544 return $x->bnan() if (($x->{sign} eq $nan) || ($y->{sign} eq $nan));
1545
1546 # inf handling
1547 if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/))
1548 {
1549 return $x->bnan() if $x->is_zero() || $y->is_zero();
1550 # result will always be +-inf:
1551 # +inf * +/+inf => +inf, -inf * -/-inf => +inf
1552 # +inf * -/-inf => -inf, -inf * +/+inf => -inf
1553 return $x->binf() if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/);
1554 return $x->binf() if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/);
1555 return $x->binf('-');
1556 }
1557
1558 return $upgrade->bmul($x,$upgrade->new($y),@r)
1559 if defined $upgrade && !$y->isa($self);
1560
1561 $r[3] = $y; # no push here
1562
1563 $x->{sign} = $x->{sign} eq $y->{sign} ? '+' : '-'; # +1 * +1 or -1 * -1 => +
1564
1565 $x->{value} = $CALC->_mul($x->{value},$y->{value}); # do actual math
1566 $x->{sign} = '+' if $CALC->_is_zero($x->{value}); # no -0
1567
1568 $x->round(@r);
1569 }
1570
1571sub bmuladd
1572 {
1573 # multiply two numbers and then add the third to the result
1574 # (BINT or num_str, BINT or num_str, BINT or num_str) return BINT
1575
1576 # set up parameters
1577 my ($self,$x,$y,$z,@r) = (ref($_[0]),@_);
1578 # objectify is costly, so avoid it
1579 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
1580 {
1581 ($self,$x,$y,$z,@r) = objectify(3,@_);
1582 }
1583
1584 return $x if $x->modify('bmuladd');
1585
1586 return $x->bnan() if ($x->{sign} eq $nan) ||
1587 ($y->{sign} eq $nan) ||
1588 ($z->{sign} eq $nan);
1589
1590 # inf handling of x and y
1591 if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/))
1592 {
1593 return $x->bnan() if $x->is_zero() || $y->is_zero();
1594 # result will always be +-inf:
1595 # +inf * +/+inf => +inf, -inf * -/-inf => +inf
1596 # +inf * -/-inf => -inf, -inf * +/+inf => -inf
1597 return $x->binf() if ($x->{sign} =~ /^\+/ && $y->{sign} =~ /^\+/);
1598 return $x->binf() if ($x->{sign} =~ /^-/ && $y->{sign} =~ /^-/);
1599 return $x->binf('-');
1600 }
1601 # inf handling x*y and z
1602 if (($z->{sign} =~ /^[+-]inf$/))
1603 {
1604 # something +-inf => +-inf
1605 $x->{sign} = $z->{sign}, return $x if $z->{sign} =~ /^[+-]inf$/;
1606 }
1607
1608 return $upgrade->bmuladd($x,$upgrade->new($y),$upgrade->new($z),@r)
1609 if defined $upgrade && (!$y->isa($self) || !$z->isa($self) || !$x->isa($self));
1610
1611 # TODO: what if $y and $z have A or P set?
1612 $r[3] = $z; # no push here
1613
1614 $x->{sign} = $x->{sign} eq $y->{sign} ? '+' : '-'; # +1 * +1 or -1 * -1 => +
1615
1616 $x->{value} = $CALC->_mul($x->{value},$y->{value}); # do actual math
1617 $x->{sign} = '+' if $CALC->_is_zero($x->{value}); # no -0
1618
1619 my ($sx, $sz) = ( $x->{sign}, $z->{sign} ); # get signs
1620
1621 if ($sx eq $sz)
1622 {
1623 $x->{value} = $CALC->_add($x->{value},$z->{value}); # same sign, abs add
1624 }
1625 else
1626 {
1627 my $a = $CALC->_acmp ($z->{value},$x->{value}); # absolute compare
1628 if ($a > 0)
1629 {
1630 $x->{value} = $CALC->_sub($z->{value},$x->{value},1); # abs sub w/ swap
1631 $x->{sign} = $sz;
1632 }
1633 elsif ($a == 0)
1634 {
1635 # speedup, if equal, set result to 0
1636 $x->{value} = $CALC->_zero();
1637 $x->{sign} = '+';
1638 }
1639 else # a < 0
1640 {
1641 $x->{value} = $CALC->_sub($x->{value}, $z->{value}); # abs sub
1642 }
1643 }
1644 $x->round(@r);
1645 }
1646
1647sub _div_inf
1648 {
1649 # helper function that handles +-inf cases for bdiv()/bmod() to reuse code
1650 my ($self,$x,$y) = @_;
1651
1652 # NaN if x == NaN or y == NaN or x==y==0
1653 return wantarray ? ($x->bnan(),$self->bnan()) : $x->bnan()
1654 if (($x->is_nan() || $y->is_nan()) ||
1655 ($x->is_zero() && $y->is_zero()));
1656
1657 # +-inf / +-inf == NaN, reminder also NaN
1658 if (($x->{sign} =~ /^[+-]inf$/) && ($y->{sign} =~ /^[+-]inf$/))
1659 {
1660 return wantarray ? ($x->bnan(),$self->bnan()) : $x->bnan();
1661 }
1662 # x / +-inf => 0, remainder x (works even if x == 0)
1663 if ($y->{sign} =~ /^[+-]inf$/)
1664 {
1665 my $t = $x->copy(); # bzero clobbers up $x
1666 return wantarray ? ($x->bzero(),$t) : $x->bzero()
1667 }
1668
1669 # 5 / 0 => +inf, -6 / 0 => -inf
1670 # +inf / 0 = inf, inf, and -inf / 0 => -inf, -inf
1671 # exception: -8 / 0 has remainder -8, not 8
1672 # exception: -inf / 0 has remainder -inf, not inf
1673 if ($y->is_zero())
1674 {
1675 # +-inf / 0 => special case for -inf
1676 return wantarray ? ($x,$x->copy()) : $x if $x->is_inf();
1677 if (!$x->is_zero() && !$x->is_inf())
1678 {
1679 my $t = $x->copy(); # binf clobbers up $x
1680 return wantarray ?
1681 ($x->binf($x->{sign}),$t) : $x->binf($x->{sign})
1682 }
1683 }
1684
1685 # last case: +-inf / ordinary number
1686 my $sign = '+inf';
1687 $sign = '-inf' if substr($x->{sign},0,1) ne $y->{sign};
1688 $x->{sign} = $sign;
1689 return wantarray ? ($x,$self->bzero()) : $x;
1690 }
1691
1692sub bdiv
1693 {
1694 # (dividend: BINT or num_str, divisor: BINT or num_str) return
1695 # (BINT,BINT) (quo,rem) or BINT (only rem)
1696
1697 # set up parameters
1698 my ($self,$x,$y,@r) = (ref($_[0]),@_);
1699 # objectify is costly, so avoid it
1700 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
1701 {
1702 ($self,$x,$y,@r) = objectify(2,@_);
1703 }
1704
1705 return $x if $x->modify('bdiv');
1706
1707 return $self->_div_inf($x,$y)
1708 if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/) || $y->is_zero());
1709
1710 return $upgrade->bdiv($upgrade->new($x),$upgrade->new($y),@r)
1711 if defined $upgrade;
1712
1713 $r[3] = $y; # no push!
1714
1715 # calc new sign and in case $y == +/- 1, return $x
1716 my $xsign = $x->{sign}; # keep
1717 $x->{sign} = ($x->{sign} ne $y->{sign} ? '-' : '+');
1718
1719 if (wantarray)
1720 {
1721 my $rem = $self->bzero();
1722 ($x->{value},$rem->{value}) = $CALC->_div($x->{value},$y->{value});
1723 $x->{sign} = '+' if $CALC->_is_zero($x->{value});
1724 $rem->{_a} = $x->{_a};
1725 $rem->{_p} = $x->{_p};
1726 $x->round(@r);
1727 if (! $CALC->_is_zero($rem->{value}))
1728 {
1729 $rem->{sign} = $y->{sign};
1730 $rem = $y->copy()->bsub($rem) if $xsign ne $y->{sign}; # one of them '-'
1731 }
1732 else
1733 {
1734 $rem->{sign} = '+'; # dont leave -0
1735 }
1736 $rem->round(@r);
1737 return ($x,$rem);
1738 }
1739
1740 $x->{value} = $CALC->_div($x->{value},$y->{value});
1741 $x->{sign} = '+' if $CALC->_is_zero($x->{value});
1742
1743 $x->round(@r);
1744 }
1745
1746###############################################################################
1747# modulus functions
1748
1749sub bmod
1750 {
1751 # modulus (or remainder)
1752 # (BINT or num_str, BINT or num_str) return BINT
1753
1754 # set up parameters
1755 my ($self,$x,$y,@r) = (ref($_[0]),@_);
1756 # objectify is costly, so avoid it
1757 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
1758 {
1759 ($self,$x,$y,@r) = objectify(2,@_);
1760 }
1761
1762 return $x if $x->modify('bmod');
1763 $r[3] = $y; # no push!
1764 if (($x->{sign} !~ /^[+-]$/) || ($y->{sign} !~ /^[+-]$/) || $y->is_zero())
1765 {
1766 my ($d,$r) = $self->_div_inf($x,$y);
1767 $x->{sign} = $r->{sign};
1768 $x->{value} = $r->{value};
1769 return $x->round(@r);
1770 }
1771
1772 # calc new sign and in case $y == +/- 1, return $x
1773 $x->{value} = $CALC->_mod($x->{value},$y->{value});
1774 if (!$CALC->_is_zero($x->{value}))
1775 {
1776 $x->{value} = $CALC->_sub($y->{value},$x->{value},1) # $y-$x
1777 if ($x->{sign} ne $y->{sign});
1778 $x->{sign} = $y->{sign};
1779 }
1780 else
1781 {
1782 $x->{sign} = '+'; # dont leave -0
1783 }
1784 $x->round(@r);
1785 }
1786
1787sub bmodinv
1788 {
1789 # Modular inverse. given a number which is (hopefully) relatively
1790 # prime to the modulus, calculate its inverse using Euclid's
1791 # alogrithm. If the number is not relatively prime to the modulus
1792 # (i.e. their gcd is not one) then NaN is returned.
1793
1794 # set up parameters
1795 my ($self,$x,$y,@r) = (undef,@_);
1796 # objectify is costly, so avoid it
1797 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
1798 {
1799 ($self,$x,$y,@r) = objectify(2,@_);
1800 }
1801
1802 return $x if $x->modify('bmodinv');
1803
1804 return $x->bnan()
1805 if ($y->{sign} ne '+' # -, NaN, +inf, -inf
1806 || $x->is_zero() # or num == 0
1807 || $x->{sign} !~ /^[+-]$/ # or num NaN, inf, -inf
1808 );
1809
1810 # put least residue into $x if $x was negative, and thus make it positive
1811 $x->bmod($y) if $x->{sign} eq '-';
1812
1813 my $sign;
1814 ($x->{value},$sign) = $CALC->_modinv($x->{value},$y->{value});
1815 return $x->bnan() if !defined $x->{value}; # in case no GCD found
1816 return $x if !defined $sign; # already real result
1817 $x->{sign} = $sign; # flip/flop see below
1818 $x->bmod($y); # calc real result
1819 $x;
1820 }
1821
1822sub bmodpow
1823 {
1824 # takes a very large number to a very large exponent in a given very
1825 # large modulus, quickly, thanks to binary exponentation. Supports
1826 # negative exponents.
1827 my ($self,$num,$exp,$mod,@r) = objectify(3,@_);
1828
1829 return $num if $num->modify('bmodpow');
1830
1831 # check modulus for valid values
1832 return $num->bnan() if ($mod->{sign} ne '+' # NaN, - , -inf, +inf
1833 || $mod->is_zero());
1834
1835 # check exponent for valid values
1836 if ($exp->{sign} =~ /\w/)
1837 {
1838 # i.e., if it's NaN, +inf, or -inf...
1839 return $num->bnan();
1840 }
1841
1842 $num->bmodinv ($mod) if ($exp->{sign} eq '-');
1843
1844 # check num for valid values (also NaN if there was no inverse but $exp < 0)
1845 return $num->bnan() if $num->{sign} !~ /^[+-]$/;
1846
1847 # $mod is positive, sign on $exp is ignored, result also positive
1848 $num->{value} = $CALC->_modpow($num->{value},$exp->{value},$mod->{value});
1849 $num;
1850 }
1851
1852###############################################################################
1853
1854sub bfac
1855 {
1856 # (BINT or num_str, BINT or num_str) return BINT
1857 # compute factorial number from $x, modify $x in place
1858 my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
1859
1860 return $x if $x->modify('bfac') || $x->{sign} eq '+inf'; # inf => inf
1861 return $x->bnan() if $x->{sign} ne '+'; # NaN, <0 etc => NaN
1862
1863 $x->{value} = $CALC->_fac($x->{value});
1864 $x->round(@r);
1865 }
1866
1867sub bpow
1868 {
1869 # (BINT or num_str, BINT or num_str) return BINT
1870 # compute power of two numbers -- stolen from Knuth Vol 2 pg 233
1871 # modifies first argument
1872
1873 # set up parameters
1874 my ($self,$x,$y,@r) = (ref($_[0]),@_);
1875 # objectify is costly, so avoid it
1876 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
1877 {
1878 ($self,$x,$y,@r) = objectify(2,@_);
1879 }
1880
1881 return $x if $x->modify('bpow');
1882
1883 return $x->bnan() if $x->{sign} eq $nan || $y->{sign} eq $nan;
1884
1885 # inf handling
1886 if (($x->{sign} =~ /^[+-]inf$/) || ($y->{sign} =~ /^[+-]inf$/))
1887 {
1888 if (($x->{sign} =~ /^[+-]inf$/) && ($y->{sign} =~ /^[+-]inf$/))
1889 {
1890 # +-inf ** +-inf
1891 return $x->bnan();
1892 }
1893 # +-inf ** Y
1894 if ($x->{sign} =~ /^[+-]inf/)
1895 {
1896 # +inf ** 0 => NaN
1897 return $x->bnan() if $y->is_zero();
1898 # -inf ** -1 => 1/inf => 0
1899 return $x->bzero() if $y->is_one('-') && $x->is_negative();
1900
1901 # +inf ** Y => inf
1902 return $x if $x->{sign} eq '+inf';
1903
1904 # -inf ** Y => -inf if Y is odd
1905 return $x if $y->is_odd();
1906 return $x->babs();
1907 }
1908 # X ** +-inf
1909
1910 # 1 ** +inf => 1
1911 return $x if $x->is_one();
1912
1913 # 0 ** inf => 0
1914 return $x if $x->is_zero() && $y->{sign} =~ /^[+]/;
1915
1916 # 0 ** -inf => inf
1917 return $x->binf() if $x->is_zero();
1918
1919 # -1 ** -inf => NaN
1920 return $x->bnan() if $x->is_one('-') && $y->{sign} =~ /^[-]/;
1921
1922 # -X ** -inf => 0
1923 return $x->bzero() if $x->{sign} eq '-' && $y->{sign} =~ /^[-]/;
1924
1925 # -1 ** inf => NaN
1926 return $x->bnan() if $x->{sign} eq '-';
1927
1928 # X ** inf => inf
1929 return $x->binf() if $y->{sign} =~ /^[+]/;
1930 # X ** -inf => 0
1931 return $x->bzero();
1932 }
1933
1934 return $upgrade->bpow($upgrade->new($x),$y,@r)
1935 if defined $upgrade && (!$y->isa($self) || $y->{sign} eq '-');
1936
1937 $r[3] = $y; # no push!
1938
1939 # cases 0 ** Y, X ** 0, X ** 1, 1 ** Y are handled by Calc or Emu
1940
1941 my $new_sign = '+';
1942 $new_sign = $y->is_odd() ? '-' : '+' if ($x->{sign} ne '+');
1943
1944 # 0 ** -7 => ( 1 / (0 ** 7)) => 1 / 0 => +inf
1945 return $x->binf()
1946 if $y->{sign} eq '-' && $x->{sign} eq '+' && $CALC->_is_zero($x->{value});
1947 # 1 ** -y => 1 / (1 ** |y|)
1948 # so do test for negative $y after above's clause
1949 return $x->bnan() if $y->{sign} eq '-' && !$CALC->_is_one($x->{value});
1950
1951 $x->{value} = $CALC->_pow($x->{value},$y->{value});
1952 $x->{sign} = $new_sign;
1953 $x->{sign} = '+' if $CALC->_is_zero($y->{value});
1954 $x->round(@r);
1955 }
1956
1957sub blsft
1958 {
1959 # (BINT or num_str, BINT or num_str) return BINT
1960 # compute x << y, base n, y >= 0
1961
1962 # set up parameters
1963 my ($self,$x,$y,$n,@r) = (ref($_[0]),@_);
1964 # objectify is costly, so avoid it
1965 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
1966 {
1967 ($self,$x,$y,$n,@r) = objectify(2,@_);
1968 }
1969
1970 return $x if $x->modify('blsft');
1971 return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
1972 return $x->round(@r) if $y->is_zero();
1973
1974 $n = 2 if !defined $n; return $x->bnan() if $n <= 0 || $y->{sign} eq '-';
1975
1976 $x->{value} = $CALC->_lsft($x->{value},$y->{value},$n);
1977 $x->round(@r);
1978 }
1979
1980sub brsft
1981 {
1982 # (BINT or num_str, BINT or num_str) return BINT
1983 # compute x >> y, base n, y >= 0
1984
1985 # set up parameters
1986 my ($self,$x,$y,$n,@r) = (ref($_[0]),@_);
1987 # objectify is costly, so avoid it
1988 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
1989 {
1990 ($self,$x,$y,$n,@r) = objectify(2,@_);
1991 }
1992
1993 return $x if $x->modify('brsft');
1994 return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
1995 return $x->round(@r) if $y->is_zero();
1996 return $x->bzero(@r) if $x->is_zero(); # 0 => 0
1997
1998 $n = 2 if !defined $n; return $x->bnan() if $n <= 0 || $y->{sign} eq '-';
1999
2000 # this only works for negative numbers when shifting in base 2
2001 if (($x->{sign} eq '-') && ($n == 2))
2002 {
2003 return $x->round(@r) if $x->is_one('-'); # -1 => -1
2004 if (!$y->is_one())
2005 {
2006 # although this is O(N*N) in calc (as_bin!) it is O(N) in Pari et al
2007 # but perhaps there is a better emulation for two's complement shift...
2008 # if $y != 1, we must simulate it by doing:
2009 # convert to bin, flip all bits, shift, and be done
2010 $x->binc(); # -3 => -2
2011 my $bin = $x->as_bin();
2012 $bin =~ s/^-0b//; # strip '-0b' prefix
2013 $bin =~ tr/10/01/; # flip bits
2014 # now shift
2015 if ($y >= CORE::length($bin))
2016 {
2017 $bin = '0'; # shifting to far right creates -1
2018 # 0, because later increment makes
2019 # that 1, attached '-' makes it '-1'
2020 # because -1 >> x == -1 !
2021 }
2022 else
2023 {
2024 $bin =~ s/.{$y}$//; # cut off at the right side
2025 $bin = '1' . $bin; # extend left side by one dummy '1'
2026 $bin =~ tr/10/01/; # flip bits back
2027 }
2028 my $res = $self->new('0b'.$bin); # add prefix and convert back
2029 $res->binc(); # remember to increment
2030 $x->{value} = $res->{value}; # take over value
2031 return $x->round(@r); # we are done now, magic, isn't?
2032 }
2033 # x < 0, n == 2, y == 1
2034 $x->bdec(); # n == 2, but $y == 1: this fixes it
2035 }
2036
2037 $x->{value} = $CALC->_rsft($x->{value},$y->{value},$n);
2038 $x->round(@r);
2039 }
2040
2041sub band
2042 {
2043 #(BINT or num_str, BINT or num_str) return BINT
2044 # compute x & y
2045
2046 # set up parameters
2047 my ($self,$x,$y,@r) = (ref($_[0]),@_);
2048 # objectify is costly, so avoid it
2049 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
2050 {
2051 ($self,$x,$y,@r) = objectify(2,@_);
2052 }
2053
2054 return $x if $x->modify('band');
2055
2056 $r[3] = $y; # no push!
2057
2058 return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
2059
2060 my $sx = $x->{sign} eq '+' ? 1 : -1;
2061 my $sy = $y->{sign} eq '+' ? 1 : -1;
2062
2063 if ($sx == 1 && $sy == 1)
2064 {
2065 $x->{value} = $CALC->_and($x->{value},$y->{value});
2066 return $x->round(@r);
2067 }
2068
2069 if ($CAN{signed_and})
2070 {
2071 $x->{value} = $CALC->_signed_and($x->{value},$y->{value},$sx,$sy);
2072 return $x->round(@r);
2073 }
2074
2075 require $EMU_LIB;
2076 __emu_band($self,$x,$y,$sx,$sy,@r);
2077 }
2078
2079sub bior
2080 {
2081 #(BINT or num_str, BINT or num_str) return BINT
2082 # compute x | y
2083
2084 # set up parameters
2085 my ($self,$x,$y,@r) = (ref($_[0]),@_);
2086 # objectify is costly, so avoid it
2087 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
2088 {
2089 ($self,$x,$y,@r) = objectify(2,@_);
2090 }
2091
2092 return $x if $x->modify('bior');
2093 $r[3] = $y; # no push!
2094
2095 return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
2096
2097 my $sx = $x->{sign} eq '+' ? 1 : -1;
2098 my $sy = $y->{sign} eq '+' ? 1 : -1;
2099
2100 # the sign of X follows the sign of X, e.g. sign of Y irrelevant for bior()
2101
2102 # don't use lib for negative values
2103 if ($sx == 1 && $sy == 1)
2104 {
2105 $x->{value} = $CALC->_or($x->{value},$y->{value});
2106 return $x->round(@r);
2107 }
2108
2109 # if lib can do negative values, let it handle this
2110 if ($CAN{signed_or})
2111 {
2112 $x->{value} = $CALC->_signed_or($x->{value},$y->{value},$sx,$sy);
2113 return $x->round(@r);
2114 }
2115
2116 require $EMU_LIB;
2117 __emu_bior($self,$x,$y,$sx,$sy,@r);
2118 }
2119
2120sub bxor
2121 {
2122 #(BINT or num_str, BINT or num_str) return BINT
2123 # compute x ^ y
2124
2125 # set up parameters
2126 my ($self,$x,$y,@r) = (ref($_[0]),@_);
2127 # objectify is costly, so avoid it
2128 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
2129 {
2130 ($self,$x,$y,@r) = objectify(2,@_);
2131 }
2132
2133 return $x if $x->modify('bxor');
2134 $r[3] = $y; # no push!
2135
2136 return $x->bnan() if ($x->{sign} !~ /^[+-]$/ || $y->{sign} !~ /^[+-]$/);
2137
2138 my $sx = $x->{sign} eq '+' ? 1 : -1;
2139 my $sy = $y->{sign} eq '+' ? 1 : -1;
2140
2141 # don't use lib for negative values
2142 if ($sx == 1 && $sy == 1)
2143 {
2144 $x->{value} = $CALC->_xor($x->{value},$y->{value});
2145 return $x->round(@r);
2146 }
2147
2148 # if lib can do negative values, let it handle this
2149 if ($CAN{signed_xor})
2150 {
2151 $x->{value} = $CALC->_signed_xor($x->{value},$y->{value},$sx,$sy);
2152 return $x->round(@r);
2153 }
2154
2155 require $EMU_LIB;
2156 __emu_bxor($self,$x,$y,$sx,$sy,@r);
2157 }
2158
2159sub length
2160 {
2161 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
2162
2163 my $e = $CALC->_len($x->{value});
2164 wantarray ? ($e,0) : $e;
2165 }
2166
2167sub digit
2168 {
2169 # return the nth decimal digit, negative values count backward, 0 is right
2170 my ($self,$x,$n) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
2171
2172 $n = $n->numify() if ref($n);
2173 $CALC->_digit($x->{value},$n||0);
2174 }
2175
2176sub _trailing_zeros
2177 {
2178 # return the amount of trailing zeros in $x (as scalar)
2179 my $x = shift;
2180 $x = $class->new($x) unless ref $x;
2181
2182 return 0 if $x->{sign} !~ /^[+-]$/; # NaN, inf, -inf etc
2183
2184 $CALC->_zeros($x->{value}); # must handle odd values, 0 etc
2185 }
2186
2187sub bsqrt
2188 {
2189 # calculate square root of $x
2190 my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
2191
2192 return $x if $x->modify('bsqrt');
2193
2194 return $x->bnan() if $x->{sign} !~ /^\+/; # -x or -inf or NaN => NaN
2195 return $x if $x->{sign} eq '+inf'; # sqrt(+inf) == inf
2196
2197 return $upgrade->bsqrt($x,@r) if defined $upgrade;
2198
2199 $x->{value} = $CALC->_sqrt($x->{value});
2200 $x->round(@r);
2201 }
2202
2203sub broot
2204 {
2205 # calculate $y'th root of $x
2206
2207 # set up parameters
2208 my ($self,$x,$y,@r) = (ref($_[0]),@_);
2209
2210 $y = $self->new(2) unless defined $y;
2211
2212 # objectify is costly, so avoid it
2213 if ((!ref($x)) || (ref($x) ne ref($y)))
2214 {
2215 ($self,$x,$y,@r) = objectify(2,$self || $class,@_);
2216 }
2217
2218 return $x if $x->modify('broot');
2219
2220 # NaN handling: $x ** 1/0, x or y NaN, or y inf/-inf or y == 0
2221 return $x->bnan() if $x->{sign} !~ /^\+/ || $y->is_zero() ||
2222 $y->{sign} !~ /^\+$/;
2223
2224 return $x->round(@r)
2225 if $x->is_zero() || $x->is_one() || $x->is_inf() || $y->is_one();
2226
2227 return $upgrade->new($x)->broot($upgrade->new($y),@r) if defined $upgrade;
2228
2229 $x->{value} = $CALC->_root($x->{value},$y->{value});
2230 $x->round(@r);
2231 }
2232
2233sub exponent
2234 {
2235 # return a copy of the exponent (here always 0, NaN or 1 for $m == 0)
2236 my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
2237
2238 if ($x->{sign} !~ /^[+-]$/)
2239 {
2240 my $s = $x->{sign}; $s =~ s/^[+-]//; # NaN, -inf,+inf => NaN or inf
2241 return $self->new($s);
2242 }
2243 return $self->bone() if $x->is_zero();
2244
2245 # 12300 => 2 trailing zeros => exponent is 2
2246 $self->new( $CALC->_zeros($x->{value}) );
2247 }
2248
2249sub mantissa
2250 {
2251 # return the mantissa (compatible to Math::BigFloat, e.g. reduced)
2252 my ($self,$x) = ref($_[0]) ? (ref($_[0]),$_[0]) : objectify(1,@_);
2253
2254 if ($x->{sign} !~ /^[+-]$/)
2255 {
2256 # for NaN, +inf, -inf: keep the sign
2257 return $self->new($x->{sign});
2258 }
2259 my $m = $x->copy(); delete $m->{_p}; delete $m->{_a};
2260
2261 # that's a bit inefficient:
2262 my $zeros = $CALC->_zeros($m->{value});
2263 $m->brsft($zeros,10) if $zeros != 0;
2264 $m;
2265 }
2266
2267sub parts
2268 {
2269 # return a copy of both the exponent and the mantissa
2270 my ($self,$x) = ref($_[0]) ? (undef,$_[0]) : objectify(1,@_);
2271
2272 ($x->mantissa(),$x->exponent());
2273 }
2274
2275##############################################################################
2276# rounding functions
2277
2278sub bfround
2279 {
2280 # precision: round to the $Nth digit left (+$n) or right (-$n) from the '.'
2281 # $n == 0 || $n == 1 => round to integer
2282 my $x = shift; my $self = ref($x) || $x; $x = $self->new($x) unless ref $x;
2283
2284 my ($scale,$mode) = $x->_scale_p(@_);
2285
2286 return $x if !defined $scale || $x->modify('bfround'); # no-op
2287
2288 # no-op for BigInts if $n <= 0
2289 $x->bround( $x->length()-$scale, $mode) if $scale > 0;
2290
2291 delete $x->{_a}; # delete to save memory
2292 $x->{_p} = $scale; # store new _p
2293 $x;
2294 }
2295
2296sub _scan_for_nonzero
2297 {
2298 # internal, used by bround() to scan for non-zeros after a '5'
2299 my ($x,$pad,$xs,$len) = @_;
2300
2301 return 0 if $len == 1; # "5" is trailed by invisible zeros
2302 my $follow = $pad - 1;
2303 return 0 if $follow > $len || $follow < 1;
2304
2305 # use the string form to check whether only '0's follow or not
2306 substr ($xs,-$follow) =~ /[^0]/ ? 1 : 0;
2307 }
2308
2309sub fround
2310 {
2311 # Exists to make life easier for switch between MBF and MBI (should we
2312 # autoload fxxx() like MBF does for bxxx()?)
2313 my $x = shift; $x = $class->new($x) unless ref $x;
2314 $x->bround(@_);
2315 }
2316
2317sub bround
2318 {
2319 # accuracy: +$n preserve $n digits from left,
2320 # -$n preserve $n digits from right (f.i. for 0.1234 style in MBF)
2321 # no-op for $n == 0
2322 # and overwrite the rest with 0's, return normalized number
2323 # do not return $x->bnorm(), but $x
2324
2325 my $x = shift; $x = $class->new($x) unless ref $x;
2326 my ($scale,$mode) = $x->_scale_a(@_);
2327 return $x if !defined $scale || $x->modify('bround'); # no-op
2328
2329 if ($x->is_zero() || $scale == 0)
2330 {
2331 $x->{_a} = $scale if !defined $x->{_a} || $x->{_a} > $scale; # 3 > 2
2332 return $x;
2333 }
2334 return $x if $x->{sign} !~ /^[+-]$/; # inf, NaN
2335
2336 # we have fewer digits than we want to scale to
2337 my $len = $x->length();
2338 # convert $scale to a scalar in case it is an object (put's a limit on the
2339 # number length, but this would already limited by memory constraints), makes
2340 # it faster
2341 $scale = $scale->numify() if ref ($scale);
2342
2343 # scale < 0, but > -len (not >=!)
2344 if (($scale < 0 && $scale < -$len-1) || ($scale >= $len))
2345 {
2346 $x->{_a} = $scale if !defined $x->{_a} || $x->{_a} > $scale; # 3 > 2
2347 return $x;
2348 }
2349
2350 # count of 0's to pad, from left (+) or right (-): 9 - +6 => 3, or |-6| => 6
2351 my ($pad,$digit_round,$digit_after);
2352 $pad = $len - $scale;
2353 $pad = abs($scale-1) if $scale < 0;
2354
2355 # do not use digit(), it is very costly for binary => decimal
2356 # getting the entire string is also costly, but we need to do it only once
2357 my $xs = $CALC->_str($x->{value});
2358 my $pl = -$pad-1;
2359
2360 # pad: 123: 0 => -1, at 1 => -2, at 2 => -3, at 3 => -4
2361 # pad+1: 123: 0 => 0, at 1 => -1, at 2 => -2, at 3 => -3
2362 $digit_round = '0'; $digit_round = substr($xs,$pl,1) if $pad <= $len;
2363 $pl++; $pl ++ if $pad >= $len;
2364 $digit_after = '0'; $digit_after = substr($xs,$pl,1) if $pad > 0;
2365
2366 # in case of 01234 we round down, for 6789 up, and only in case 5 we look
2367 # closer at the remaining digits of the original $x, remember decision
2368 my $round_up = 1; # default round up
2369 $round_up -- if
2370 ($mode eq 'trunc') || # trunc by round down
2371 ($digit_after =~ /[01234]/) || # round down anyway,
2372 # 6789 => round up
2373 ($digit_after eq '5') && # not 5000...0000
2374 ($x->_scan_for_nonzero($pad,$xs,$len) == 0) &&
2375 (
2376 ($mode eq 'even') && ($digit_round =~ /[24680]/) ||
2377 ($mode eq 'odd') && ($digit_round =~ /[13579]/) ||
2378 ($mode eq '+inf') && ($x->{sign} eq '-') ||
2379 ($mode eq '-inf') && ($x->{sign} eq '+') ||
2380 ($mode eq 'zero') # round down if zero, sign adjusted below
2381 );
2382 my $put_back = 0; # not yet modified
2383
2384 if (($pad > 0) && ($pad <= $len))
2385 {
2386 substr($xs,-$pad,$pad) = '0' x $pad; # replace with '00...'
2387 $put_back = 1; # need to put back
2388 }
2389 elsif ($pad > $len)
2390 {
2391 $x->bzero(); # round to '0'
2392 }
2393
2394 if ($round_up) # what gave test above?
2395 {
2396 $put_back = 1; # need to put back
2397 $pad = $len, $xs = '0' x $pad if $scale < 0; # tlr: whack 0.51=>1.0
2398
2399 # we modify directly the string variant instead of creating a number and
2400 # adding it, since that is faster (we already have the string)
2401 my $c = 0; $pad ++; # for $pad == $len case
2402 while ($pad <= $len)
2403 {
2404 $c = substr($xs,-$pad,1) + 1; $c = '0' if $c eq '10';
2405 substr($xs,-$pad,1) = $c; $pad++;
2406 last if $c != 0; # no overflow => early out
2407 }
2408 $xs = '1'.$xs if $c == 0;
2409
2410 }
2411 $x->{value} = $CALC->_new($xs) if $put_back == 1; # put back, if needed
2412
2413 $x->{_a} = $scale if $scale >= 0;
2414 if ($scale < 0)
2415 {
2416 $x->{_a} = $len+$scale;
2417 $x->{_a} = 0 if $scale < -$len;
2418 }
2419 $x;
2420 }
2421
2422sub bfloor
2423 {
2424 # return integer less or equal then number; no-op since it's already integer
2425 my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
2426
2427 $x->round(@r);
2428 }
2429
2430sub bceil
2431 {
2432 # return integer greater or equal then number; no-op since it's already int
2433 my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
2434
2435 $x->round(@r);
2436 }
2437
2438sub as_number
2439 {
2440 # An object might be asked to return itself as bigint on certain overloaded
2441 # operations. This does exactly this, so that sub classes can simple inherit
2442 # it or override with their own integer conversion routine.
2443 $_[0]->copy();
2444 }
2445
2446sub as_hex
2447 {
2448 # return as hex string, with prefixed 0x
2449 my $x = shift; $x = $class->new($x) if !ref($x);
2450
2451 return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc
2452
2453 my $s = '';
2454 $s = $x->{sign} if $x->{sign} eq '-';
2455 $s . $CALC->_as_hex($x->{value});
2456 }
2457
2458sub as_bin
2459 {
2460 # return as binary string, with prefixed 0b
2461 my $x = shift; $x = $class->new($x) if !ref($x);
2462
2463 return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc
2464
2465 my $s = ''; $s = $x->{sign} if $x->{sign} eq '-';
2466 return $s . $CALC->_as_bin($x->{value});
2467 }
2468
2469sub as_oct
2470 {
2471 # return as octal string, with prefixed 0
2472 my $x = shift; $x = $class->new($x) if !ref($x);
2473
2474 return $x->bstr() if $x->{sign} !~ /^[+-]$/; # inf, nan etc
2475
2476 my $s = ''; $s = $x->{sign} if $x->{sign} eq '-';
2477 return $s . $CALC->_as_oct($x->{value});
2478 }
2479
2480##############################################################################
2481# private stuff (internal use only)
2482
2483sub objectify
2484 {
2485 # check for strings, if yes, return objects instead
2486
2487 # the first argument is number of args objectify() should look at it will
2488 # return $count+1 elements, the first will be a classname. This is because
2489 # overloaded '""' calls bstr($object,undef,undef) and this would result in
2490 # useless objects being created and thrown away. So we cannot simple loop
2491 # over @_. If the given count is 0, all arguments will be used.
2492
2493 # If the second arg is a ref, use it as class.
2494 # If not, try to use it as classname, unless undef, then use $class
2495 # (aka Math::BigInt). The latter shouldn't happen,though.
2496
2497 # caller: gives us:
2498 # $x->badd(1); => ref x, scalar y
2499 # Class->badd(1,2); => classname x (scalar), scalar x, scalar y
2500 # Class->badd( Class->(1),2); => classname x (scalar), ref x, scalar y
2501 # Math::BigInt::badd(1,2); => scalar x, scalar y
2502 # In the last case we check number of arguments to turn it silently into
2503 # $class,1,2. (We can not take '1' as class ;o)
2504 # badd($class,1) is not supported (it should, eventually, try to add undef)
2505 # currently it tries 'Math::BigInt' + 1, which will not work.
2506
2507 # some shortcut for the common cases
2508 # $x->unary_op();
2509 return (ref($_[1]),$_[1]) if (@_ == 2) && ($_[0]||0 == 1) && ref($_[1]);
2510
2511 my $count = abs(shift || 0);
2512
2513 my (@a,$k,$d); # resulting array, temp, and downgrade
2514 if (ref $_[0])
2515 {
2516 # okay, got object as first
2517 $a[0] = ref $_[0];
2518 }
2519 else
2520 {
2521 # nope, got 1,2 (Class->xxx(1) => Class,1 and not supported)
2522 $a[0] = $class;
2523 $a[0] = shift if $_[0] =~ /^[A-Z].*::/; # classname as first?
2524 }
2525
252632.26ms276µs
# spent 47µs (19+28) within Math::BigInt::BEGIN@2526 which was called: # once (19µs+28µs) by Library::CallNumber::LC::BEGIN@5 at line 2526
no strict 'refs';
# spent 47µs making 1 call to Math::BigInt::BEGIN@2526 # spent 28µs making 1 call to strict::unimport
2527 # disable downgrading, because Math::BigFLoat->foo('1.0','2.0') needs floats
2528 if (defined ${"$a[0]::downgrade"})
2529 {
2530 $d = ${"$a[0]::downgrade"};
2531 ${"$a[0]::downgrade"} = undef;
2532 }
2533
2534 my $up = ${"$a[0]::upgrade"};
2535 # print STDERR "# Now in objectify, my class is today $a[0], count = $count\n";
2536 if ($count == 0)
2537 {
2538 while (@_)
2539 {
2540 $k = shift;
2541 if (!ref($k))
2542 {
2543 $k = $a[0]->new($k);
2544 }
2545 elsif (!defined $up && ref($k) ne $a[0])
2546 {
2547 # foreign object, try to convert to integer
2548 $k->can('as_number') ? $k = $k->as_number() : $k = $a[0]->new($k);
2549 }
2550 push @a,$k;
2551 }
2552 }
2553 else
2554 {
2555 while ($count > 0)
2556 {
2557 $count--;
2558 $k = shift;
2559 if (!ref($k))
2560 {
2561 $k = $a[0]->new($k);
2562 }
2563 elsif (!defined $up && ref($k) ne $a[0])
2564 {
2565 # foreign object, try to convert to integer
2566 $k->can('as_number') ? $k = $k->as_number() : $k = $a[0]->new($k);
2567 }
2568 push @a,$k;
2569 }
2570 push @a,@_; # return other params, too
2571 }
2572 if (! wantarray)
2573 {
2574 require Carp; Carp::croak ("$class objectify needs list context");
2575 }
2576 ${"$a[0]::downgrade"} = $d;
2577 @a;
2578 }
2579
2580sub _register_callback
2581 {
2582 my ($class,$callback) = @_;
2583
2584 if (ref($callback) ne 'CODE')
2585 {
2586 require Carp;
2587 Carp::croak ("$callback is not a coderef");
2588 }
2589 $CALLBACKS{$class} = $callback;
2590 }
2591
2592sub import
2593
# spent 13.8ms (298µs+13.5) within Math::BigInt::import which was called: # once (298µs+13.5ms) by Library::CallNumber::LC::BEGIN@5 at line 5 of Library/CallNumber/LC.pm
{
25941600ns my $self = shift;
2595
25961500ns $IMPORT++; # remember we did import()
25972600ns my @a; my $l = scalar @_;
25981400ns my $warn_or_die = 0; # 0 - no warn, 1 - warn, 2 - die
259912µs for ( my $i = 0; $i < $l ; $i++ )
2600 {
2601 if ($_[$i] eq ':constant')
2602 {
2603 # this causes overlord er load to step in
2604 overload::constant
2605 integer => sub { $self->new(shift) },
2606 binary => sub { $self->new(shift) };
2607 }
2608 elsif ($_[$i] eq 'upgrade')
2609 {
2610 # this causes upgrading
2611 $upgrade = $_[$i+1]; # or undef to disable
2612 $i++;
2613 }
2614 elsif ($_[$i] =~ /^(lib|try|only)\z/)
2615 {
2616 # this causes a different low lib to take care...
2617 $CALC = $_[$i+1] || '';
2618 # lib => 1 (warn on fallback), try => 0 (no warn), only => 2 (die on fallback)
2619 $warn_or_die = 1 if $_[$i] eq 'lib';
2620 $warn_or_die = 2 if $_[$i] eq 'only';
2621 $i++;
2622 }
2623 else
2624 {
2625 push @a, $_[$i];
2626 }
26271200ns }
2628 # any non :constant stuff is handled by our parent, Exporter
26291700ns if (@a > 0)
2630 {
2631 require Exporter;
2632
2633 $self->SUPER::import(@a); # need it for subclasses
2634 $self->export_to_level(1,$self,@a); # need it for MBF
2635 }
2636
2637 # try to load core math lib
263813µs my @c = split /\s*,\s*/,$CALC;
263911µs foreach (@c)
2640 {
264112µs $_ =~ tr/a-zA-Z0-9://cd; # limit to sane characters
2642 }
26431700ns push @c, \'FastCalc', \'Calc' # if all fail, try these
2644 if $warn_or_die < 2; # but not for "only"
26451300ns $CALC = ''; # signal error
26461500ns foreach my $l (@c)
2647 {
2648 # fallback libraries are "marked" as \'string', extract string if nec.
26492600ns my $lib = $l; $lib = $$l if ref($l);
2650
26511900ns next if ($lib || '') eq '';
265215µs12µs $lib = 'Math::BigInt::'.$lib if $lib !~ /^Math::BigInt/i;
# spent 2µs making 1 call to Math::BigInt::CORE:match
265316µs11µs $lib =~ s/\.pm$//;
# spent 1µs making 1 call to Math::BigInt::CORE:subst
265414µs if ($] < 5.006)
2655 {
2656 # Perl < 5.6.0 dies with "out of memory!" when eval("") and ':constant' is
2657 # used in the same script, or eval("") inside import().
2658 my @parts = split /::/, $lib; # Math::BigInt => Math BigInt
2659 my $file = pop @parts; $file .= '.pm'; # BigInt => BigInt.pm
2660 require File::Spec;
2661 $file = File::Spec->catfile (@parts, $file);
2662 eval { require "$file"; $lib->import( @c ); }
2663 }
2664 else
2665 {
2666158µs eval "use $lib qw/@c/;";
# spent 132µs executing statements in string eval
# includes 475µs spent executing 1 call to 1 sub defined therein.
2667 }
266811µs if ($@ eq '')
2669 {
26701700ns my $ok = 1;
2671 # loaded it ok, see if the api_version() is high enough
2672125µs24µs if ($lib->can('api_version') && $lib->api_version() >= 1.0)
# spent 3µs making 1 call to UNIVERSAL::can # spent 900ns making 1 call to Math::BigInt::FastCalc::api_version
2673 {
26741600ns $ok = 0;
2675 # api_version matches, check if it really provides anything we need
267613µs for my $method (qw/
2677 one two ten
2678 str num
2679 add mul div sub dec inc
2680 acmp len digit is_one is_zero is_even is_odd
2681 is_two is_ten
2682 zeros new copy check
2683 from_hex from_oct from_bin as_hex as_bin as_oct
2684 rsft lsft xor and or
2685 mod sqrt root fac pow modinv modpow log_int gcd
2686 /)
2687 {
268844223µs4488µs if (!$lib->can("_$method"))
# spent 88µs making 44 calls to UNIVERSAL::can, avg 2µs/call
2689 {
2690 if (($WARN{$lib}||0) < 2)
2691 {
2692 require Carp;
2693 Carp::carp ("$lib is missing method '_$method'");
2694 $WARN{$lib} = 1; # still warn about the lib
2695 }
2696 $ok++; last;
2697 }
2698 }
2699 }
270012µs if ($ok == 0)
2701 {
270211µs $CALC = $lib;
270311µs if ($warn_or_die > 0 && ref($l))
2704 {
2705 require Carp;
2706 my $msg = "Math::BigInt: couldn't load specified math lib(s), fallback to $lib";
2707 Carp::carp ($msg) if $warn_or_die == 1;
2708 Carp::croak ($msg) if $warn_or_die == 2;
2709 }
271013µs last; # found a usable one, break
2711 }
2712 else
2713 {
2714 if (($WARN{$lib}||0) < 2)
2715 {
2716 my $ver = eval "\$$lib\::VERSION" || 'unknown';
2717 require Carp;
2718 Carp::carp ("Cannot load outdated $lib v$ver, please upgrade");
2719 $WARN{$lib} = 2; # never warn again
2720 }
2721 }
2722 }
2723 }
272412µs if ($CALC eq '')
2725 {
2726 require Carp;
2727 if ($warn_or_die == 2)
2728 {
2729 Carp::croak ("Couldn't load specified math lib(s) and fallback disallowed");
2730 }
2731 else
2732 {
2733 Carp::croak ("Couldn't load any math lib(s), not even fallback to Calc.pm");
2734 }
2735 }
2736
2737 # notify callbacks
273814µs foreach my $class (keys %CALLBACKS)
2739 {
2740 &{$CALLBACKS{$class}}($CALC);
2741 }
2742
2743 # Fill $CAN with the results of $CALC->can(...) for emulating lower math lib
2744 # functions
2745
274612µs %CAN = ();
274718µs for my $method (qw/ signed_and signed_or signed_xor /)
2748 {
2749339µs314µs $CAN{$method} = $CALC->can("_$method") ? 1 : 0;
# spent 14µs making 3 calls to UNIVERSAL::can, avg 5µs/call
2750 }
2751
2752 # import done
2753 }
2754
2755sub from_hex
2756 {
2757 # create a bigint from a hexadecimal string
2758 my ($self, $hs) = @_;
2759
2760 my $rc = __from_hex($hs);
2761
2762 return $self->bnan() unless defined $rc;
2763
2764 $rc;
2765 }
2766
2767sub from_bin
2768 {
2769 # create a bigint from a hexadecimal string
2770 my ($self, $bs) = @_;
2771
2772 my $rc = __from_bin($bs);
2773
2774 return $self->bnan() unless defined $rc;
2775
2776 $rc;
2777 }
2778
2779sub from_oct
2780 {
2781 # create a bigint from a hexadecimal string
2782 my ($self, $os) = @_;
2783
2784 my $x = $self->bzero();
2785
2786 # strip underscores
2787 $os =~ s/([0-7])_([0-7])/$1$2/g;
2788 $os =~ s/([0-7])_([0-7])/$1$2/g;
2789
2790 return $x->bnan() if $os !~ /^[\-\+]?0[0-7]+\z/;
2791
2792 my $sign = '+'; $sign = '-' if $os =~ /^-/;
2793
2794 $os =~ s/^[+-]//; # strip sign
2795 $x->{value} = $CALC->_from_oct($os);
2796 $x->{sign} = $sign unless $CALC->_is_zero($x->{value}); # no '-0'
2797 $x;
2798 }
2799
2800sub __from_hex
2801 {
2802 # internal
2803 # convert a (ref to) big hex string to BigInt, return undef for error
2804 my $hs = shift;
2805
2806 my $x = Math::BigInt->bzero();
2807
2808 # strip underscores
2809 $hs =~ s/([0-9a-fA-F])_([0-9a-fA-F])/$1$2/g;
2810 $hs =~ s/([0-9a-fA-F])_([0-9a-fA-F])/$1$2/g;
2811
2812 return $x->bnan() if $hs !~ /^[\-\+]?0x[0-9A-Fa-f]+$/;
2813
2814 my $sign = '+'; $sign = '-' if $hs =~ /^-/;
2815
2816 $hs =~ s/^[+-]//; # strip sign
2817 $x->{value} = $CALC->_from_hex($hs);
2818 $x->{sign} = $sign unless $CALC->_is_zero($x->{value}); # no '-0'
2819 $x;
2820 }
2821
2822sub __from_bin
2823 {
2824 # internal
2825 # convert a (ref to) big binary string to BigInt, return undef for error
2826 my $bs = shift;
2827
2828 my $x = Math::BigInt->bzero();
2829
2830 # strip underscores
2831 $bs =~ s/([01])_([01])/$1$2/g;
2832 $bs =~ s/([01])_([01])/$1$2/g;
2833 return $x->bnan() if $bs !~ /^[+-]?0b[01]+$/;
2834
2835 my $sign = '+'; $sign = '-' if $bs =~ /^\-/;
2836 $bs =~ s/^[+-]//; # strip sign
2837
2838 $x->{value} = $CALC->_from_bin($bs);
2839 $x->{sign} = $sign unless $CALC->_is_zero($x->{value}); # no '-0'
2840 $x;
2841 }
2842
2843sub _split
2844
# spent 65µs (42+23) within Math::BigInt::_split which was called: # once (42µs+23µs) by Math::BigInt::new at line 566
{
2845 # input: num_str; output: undef for invalid or
2846 # (\$mantissa_sign,\$mantissa_value,\$mantissa_fraction,\$exp_sign,\$exp_value)
2847 # Internal, take apart a string and return the pieces.
2848 # Strip leading/trailing whitespace, leading zeros, underscore and reject
2849 # invalid input.
285012µs my $x = shift;
2851
2852 # strip white space at front, also extranous leading zeros
2853135µs316µs $x =~ s/^\s*([-]?)0*([0-9])/$1$2/g; # will not strip ' .2'
# spent 12µs making 1 call to Math::BigInt::CORE:subst # spent 4µs making 2 calls to Math::BigInt::CORE:substcont, avg 2µs/call
285416µs12µs $x =~ s/^\s+//; # but this will
# spent 2µs making 1 call to Math::BigInt::CORE:subst
285515µs12µs $x =~ s/\s+$//g; # strip white space at end
# spent 2µs making 1 call to Math::BigInt::CORE:subst
2856
2857 # shortcut, if nothing to split, return early
285816µs12µs if ($x =~ /^[+-]?[0-9]+\z/)
# spent 2µs making 1 call to Math::BigInt::CORE:match
2859 {
286025µs1800ns $x =~ s/^([+-])0*([0-9])/$2/; my $sign = $1 || '+';
# spent 800ns making 1 call to Math::BigInt::CORE:subst
2861113µs return (\$sign, \$x, \'', \'', \0);
2862 }
2863
2864 # invalid starting char?
2865 return if $x !~ /^[+-]?(\.?[0-9]|0b[0-1]|0x[0-9a-fA-F])/;
2866
2867 return __from_hex($x) if $x =~ /^[\-\+]?0x/; # hex string
2868 return __from_bin($x) if $x =~ /^[\-\+]?0b/; # binary string
2869
2870 # strip underscores between digits
2871 $x =~ s/([0-9])_([0-9])/$1$2/g;
2872 $x =~ s/([0-9])_([0-9])/$1$2/g; # do twice for 1_2_3
2873
2874 # some possible inputs:
2875 # 2.1234 # 0.12 # 1 # 1E1 # 2.134E1 # 434E-10 # 1.02009E-2
2876 # .2 # 1_2_3.4_5_6 # 1.4E1_2_3 # 1e3 # +.2 # 0e999
2877
2878 my ($m,$e,$last) = split /[Ee]/,$x;
2879 return if defined $last; # last defined => 1e2E3 or others
2880 $e = '0' if !defined $e || $e eq "";
2881
2882 # sign,value for exponent,mantint,mantfrac
2883 my ($es,$ev,$mis,$miv,$mfv);
2884 # valid exponent?
2885 if ($e =~ /^([+-]?)0*([0-9]+)$/) # strip leading zeros
2886 {
2887 $es = $1; $ev = $2;
2888 # valid mantissa?
2889 return if $m eq '.' || $m eq '';
2890 my ($mi,$mf,$lastf) = split /\./,$m;
2891 return if defined $lastf; # lastf defined => 1.2.3 or others
2892 $mi = '0' if !defined $mi;
2893 $mi .= '0' if $mi =~ /^[\-\+]?$/;
2894 $mf = '0' if !defined $mf || $mf eq '';
2895 if ($mi =~ /^([+-]?)0*([0-9]+)$/) # strip leading zeros
2896 {
2897 $mis = $1||'+'; $miv = $2;
2898 return unless ($mf =~ /^([0-9]*?)0*$/); # strip trailing zeros
2899 $mfv = $1;
2900 # handle the 0e999 case here
2901 $ev = 0 if $miv eq '0' && $mfv eq '';
2902 return (\$mis,\$miv,\$mfv,\$es,\$ev);
2903 }
2904 }
2905 return; # NaN, not a number
2906 }
2907
2908##############################################################################
2909# internal calculation routines (others are in Math::BigInt::Calc etc)
2910
2911sub __lcm
2912 {
2913 # (BINT or num_str, BINT or num_str) return BINT
2914 # does modify first argument
2915 # LCM
2916
2917 my ($x,$ty) = @_;
2918 return $x->bnan() if ($x->{sign} eq $nan) || ($ty->{sign} eq $nan);
2919 my $method = ref($x) . '::bgcd';
29203781µs245µs
# spent 28µs (12+17) within Math::BigInt::BEGIN@2920 which was called: # once (12µs+17µs) by Library::CallNumber::LC::BEGIN@5 at line 2920
no strict 'refs';
# spent 28µs making 1 call to Math::BigInt::BEGIN@2920 # spent 17µs making 1 call to strict::unimport
2921 $x * $ty / &$method($x,$ty);
2922 }
2923
2924###############################################################################
2925# trigonometric functions
2926
2927sub bpi
2928 {
2929 # Calculate PI to N digits. Unless upgrading is in effect, returns the
2930 # result truncated to an integer, that is, always returns '3'.
2931 my ($self,$n) = @_;
2932 if (@_ == 1)
2933 {
2934 # called like Math::BigInt::bpi(10);
2935 $n = $self; $self = $class;
2936 }
2937 $self = ref($self) if ref($self);
2938
2939 return $upgrade->new($n) if defined $upgrade;
2940
2941 # hard-wired to "3"
2942 $self->new(3);
2943 }
2944
2945sub bcos
2946 {
2947 # Calculate cosinus(x) to N digits. Unless upgrading is in effect, returns the
2948 # result truncated to an integer.
2949 my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
2950
2951 return $x if $x->modify('bcos');
2952
2953 return $x->bnan() if $x->{sign} !~ /^[+-]\z/; # -inf +inf or NaN => NaN
2954
2955 return $upgrade->new($x)->bcos(@r) if defined $upgrade;
2956
2957 require Math::BigFloat;
2958 # calculate the result and truncate it to integer
2959 my $t = Math::BigFloat->new($x)->bcos(@r)->as_int();
2960
2961 $x->bone() if $t->is_one();
2962 $x->bzero() if $t->is_zero();
2963 $x->round(@r);
2964 }
2965
2966sub bsin
2967 {
2968 # Calculate sinus(x) to N digits. Unless upgrading is in effect, returns the
2969 # result truncated to an integer.
2970 my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
2971
2972 return $x if $x->modify('bsin');
2973
2974 return $x->bnan() if $x->{sign} !~ /^[+-]\z/; # -inf +inf or NaN => NaN
2975
2976 return $upgrade->new($x)->bsin(@r) if defined $upgrade;
2977
2978 require Math::BigFloat;
2979 # calculate the result and truncate it to integer
2980 my $t = Math::BigFloat->new($x)->bsin(@r)->as_int();
2981
2982 $x->bone() if $t->is_one();
2983 $x->bzero() if $t->is_zero();
2984 $x->round(@r);
2985 }
2986
2987sub batan2
2988 {
2989 # calculate arcus tangens of ($y/$x)
2990
2991 # set up parameters
2992 my ($self,$y,$x,@r) = (ref($_[0]),@_);
2993 # objectify is costly, so avoid it
2994 if ((!ref($_[0])) || (ref($_[0]) ne ref($_[1])))
2995 {
2996 ($self,$y,$x,@r) = objectify(2,@_);
2997 }
2998
2999 return $y if $y->modify('batan2');
3000
3001 return $y->bnan() if ($y->{sign} eq $nan) || ($x->{sign} eq $nan);
3002
3003 # Y X
3004 # != 0 -inf result is +- pi
3005 if ($x->is_inf() || $y->is_inf())
3006 {
3007 # upgrade to BigFloat etc.
3008 return $upgrade->new($y)->batan2($upgrade->new($x),@r) if defined $upgrade;
3009 if ($y->is_inf())
3010 {
3011 if ($x->{sign} eq '-inf')
3012 {
3013 # calculate 3 pi/4 => 2.3.. => 2
3014 $y->bone( substr($y->{sign},0,1) );
3015 $y->bmul($self->new(2));
3016 }
3017 elsif ($x->{sign} eq '+inf')
3018 {
3019 # calculate pi/4 => 0.7 => 0
3020 $y->bzero();
3021 }
3022 else
3023 {
3024 # calculate pi/2 => 1.5 => 1
3025 $y->bone( substr($y->{sign},0,1) );
3026 }
3027 }
3028 else
3029 {
3030 if ($x->{sign} eq '+inf')
3031 {
3032 # calculate pi/4 => 0.7 => 0
3033 $y->bzero();
3034 }
3035 else
3036 {
3037 # PI => 3.1415.. => 3
3038 $y->bone( substr($y->{sign},0,1) );
3039 $y->bmul($self->new(3));
3040 }
3041 }
3042 return $y;
3043 }
3044
3045 return $upgrade->new($y)->batan2($upgrade->new($x),@r) if defined $upgrade;
3046
3047 require Math::BigFloat;
3048 my $r = Math::BigFloat->new($y)->batan2(Math::BigFloat->new($x),@r)->as_int();
3049
3050 $x->{value} = $r->{value};
3051 $x->{sign} = $r->{sign};
3052
3053 $x;
3054 }
3055
3056sub batan
3057 {
3058 # Calculate arcus tangens of x to N digits. Unless upgrading is in effect, returns the
3059 # result truncated to an integer.
3060 my ($self,$x,@r) = ref($_[0]) ? (undef,@_) : objectify(1,@_);
3061
3062 return $x if $x->modify('batan');
3063
3064 return $x->bnan() if $x->{sign} !~ /^[+-]\z/; # -inf +inf or NaN => NaN
3065
3066 return $upgrade->new($x)->batan(@r) if defined $upgrade;
3067
3068 # calculate the result and truncate it to integer
3069 my $t = Math::BigFloat->new($x)->batan(@r);
3070
3071 $x->{value} = $CALC->_new( $x->as_int()->bstr() );
3072 $x->round(@r);
3073 }
3074
3075###############################################################################
3076# this method returns 0 if the object can be modified, or 1 if not.
3077# We use a fast constant sub() here, to avoid costly calls. Subclasses
3078# may override it with special code (f.i. Math::BigInt::Constant does so)
3079
3080sub modify () { 0; }
3081
3082111µs1;
3083__END__
 
# spent 25µs within Math::BigInt::CORE:match which was called 7 times, avg 4µs/call: # once (12µs+0s) by Math::BigInt::round_mode at line 214 # once (4µs+0s) by Math::BigInt::new at line 534 # once (2µs+0s) by Math::BigInt::_split at line 2858 # once (2µs+0s) by Math::BigInt::new at line 639 # once (2µs+0s) by Math::BigInt::import at line 2652 # once (1µs+0s) by Math::BigInt::bstr at line 827 # once (700ns+0s) by Math::BigInt::new at line 560
sub Math::BigInt::CORE:match; # opcode
# spent 18µs within Math::BigInt::CORE:subst which was called 5 times, avg 4µs/call: # once (12µs+0s) by Math::BigInt::_split at line 2853 # once (2µs+0s) by Math::BigInt::_split at line 2854 # once (2µs+0s) by Math::BigInt::_split at line 2855 # once (1µs+0s) by Math::BigInt::import at line 2653 # once (800ns+0s) by Math::BigInt::_split at line 2860
sub Math::BigInt::CORE:subst; # opcode
# spent 4µs within Math::BigInt::CORE:substcont which was called 2 times, avg 2µs/call: # 2 times (4µs+0s) by Math::BigInt::_split at line 2853, avg 2µs/call
sub Math::BigInt::CORE:substcont; # opcode
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.