File Coverage

blib/lib/Math/Decimal.pm
Criterion Covered Total %
statement 202 202 100.0
branch 154 154 100.0
condition 36 36 100.0
subroutine 32 32 100.0
pod 19 19 100.0
total 443 443 100.0


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Math::Decimal - arithmetic in decimal
4              
5             =head1 SYNOPSIS
6              
7             use Math::Decimal qw($dec_number_rx);
8              
9             if($arg =~ /\A$dec_number_rx\z/o) { ...
10             # and other regular expressions
11              
12             use Math::Decimal qw(is_dec_number check_dec_number);
13              
14             if(is_dec_number($arg)) { ...
15             check_dec_number($arg);
16              
17             use Math::Decimal qw(dec_canonise);
18              
19             $r = dec_canonise($a);
20              
21             use Math::Decimal qw(
22             dec_sgn dec_abs
23             dec_cmp dec_min dec_max
24             dec_neg dec_add dec_sub
25             dec_pow10 dec_mul_pow10
26             dec_mul
27             dec_rndiv_and_rem dec_rndiv
28             dec_round_and_rem dec_round
29             dec_rem
30             );
31              
32             $v = dec_sgn($a);
33             $v = dec_abs($a);
34             @v = sort { dec_cmp($a, $b) } @a;
35             $v = dec_min($a, $b);
36             $v = dec_max($a, $b);
37             $v = dec_neg($a);
38             $v = dec_add($a, $b);
39             $v = dec_sub($a, $b);
40             $v = dec_pow10($a);
41             $v = dec_mul_pow10($a, $b);
42             $v = dec_mul($a, $b);
43             ($q, $r) = dec_rndiv_and_rem("NEAR_EVN", $a, $b);
44             $q = dec_rndiv("NEAR_EVN", $a, $b);
45             ($v, $r) = dec_round_and_rem("NEAR_EVN", $a, $b);
46             $v = dec_round("NEAR_EVN", $a, $b);
47             $r = dec_rem("NEAR_EVN", $a, $b);
48              
49             =head1 DESCRIPTION
50              
51             This module performs basic arithmetic with arbitrary-precision numbers
52             expressed in decimal in ordinary Perl strings. The numbers can be
53             arbitrarily large, and can involve arbitrarily small fractions, and
54             all results are exact. This differs from Perl's standard arithmetic,
55             which is limited-precision binary (floating point) arithmetic. However,
56             because Perl performs implicit conversions between strings and numbers,
57             using decimal in the string form, it is extremely easy to exchange values
58             between this module and Perl's native arithmetic.
59              
60             Although Perl's scalars have space to store a number directly, that is
61             not used here. This module operates only on the string part of scalars,
62             ignoring the Perlish numerics entirely. It is not confused by dualvars
63             (scalars with independent string and number values).
64              
65             Numbers are represented in strings in a simple format, consisting of
66             optional sign, one or more integer digits, then optionally a dot (for
67             the decimal point) and one or more fractional digits. All representable
68             numbers have infinitely many acceptable representations (by adding leading
69             and trailing zero digits). The functions of this module consistently
70             return numbers in their shortest possible form.
71              
72             This module is intended for situations where exact numeric behaviour is
73             important, and Perl's default arithmetic is inadequate because fractions
74             or large numbers are involved, but the arithmetic makes up only a small
75             part of the program's behaviour. In those situations, it is convenient
76             that the functions here operate directly on strings that are useful
77             elsewhere in the program. If arithmetic is a large part of the program,
78             it will probably be better to use specialised (non-string) numeric object
79             types, such as those of L. These objects are less convenient
80             for interoperation, but arithmetic with them is more efficient.
81              
82             If you need to represent arbitrary (non-decimal) fractions exactly,
83             such as 1/3, then this module is not suitable. In that case you need a
84             general rational arithmetic module, such as L. Be prepared
85             to pay a large performance penalty for it.
86              
87             Most of this module is implemented in XS, with a pure Perl backup version
88             for systems that can't handle XS.
89              
90             =head1 THEORY
91              
92             The numbers processed by this module, the decimals, are those of the
93             form M * 10^-E, where M is an integer and E is a non-negative integer,
94             with range otherwise unlimited. (For any such number there are actually
95             an infinite number of possible (M, E) tuples: if a certain E value is
96             possible then all greater integers are also possible E values.) It is
97             an infinite set of cardinality aleph-0 (although this implementation is
98             hampered by the finiteness of computer memory). The set includes both
99             positive and negative numbers, and zero. It is a proper superset of the
100             integers, and a proper subset of the rationals. There are no infinite
101             numbers, nulls, irrationals, non-real complex numbers, or signed zeroes.
102              
103             Like the set of integers, the set of decimals is closed under mathematical
104             addition, subtraction, and multiplication. It thus forms a commutative
105             ring (in fact, an integral domain). Unlike the set of rationals, it is
106             not closed under exact division, and so it does not form a field.
107              
108             The arithmetic operations supplied by this module are those of ordinary
109             mathematical arithmetic. They thus obey the usual identities, such as
110             associativity (of addition and multiplication) and cancellation laws.
111             (This is unlike floating point arithmetic. Any system of floating
112             point numbers is not closed under mathematical addition, for example,
113             but by construction it is closed under floating point addition, which
114             necessarily differs from mathematical addition. Floating point addition
115             does not obey associativity or cancellation laws.)
116              
117             =head1 ROUNDING MODES
118              
119             For rounding division operations, a rounding mode must be specified.
120             It is given as a short string, which may be any of these:
121              
122             =over
123              
124             =item B
125              
126             towards zero
127              
128             =item B
129              
130             away from zero
131              
132             =item B
133              
134             floor: downwards (toward negative infinity)
135              
136             =item B
137              
138             ceiling: upwards (toward positive infinity)
139              
140             =item B
141              
142             to even
143              
144             =item B
145              
146             to odd
147              
148             =item BI
149              
150             to nearest, breaking ties according to I (which must be one of
151             the six above)
152              
153             =item B
154              
155             C if any rounding is required
156              
157             =back
158              
159             The mode "B" (rounding to nearest, breaking ties to the even
160             number), commonly known as "bankers' rounding", is usually the best for
161             general rounding purposes.
162              
163             =cut
164              
165             package Math::Decimal;
166              
167 18     18   565164 { use 5.006; }
  18         71  
  18         840  
168 18     18   121 use warnings;
  18         38  
  18         701  
169 18     18   99 use strict;
  18         43  
  18         711  
170              
171 18     18   98 use Carp qw(croak);
  18         66  
  18         1307  
172 18     18   15918 use Params::Classify 0.000 qw(is_string);
  18         26293  
  18         1493  
173              
174             our $VERSION = "0.003";
175              
176 18     18   160 use parent "Exporter";
  18         35  
  18         90  
177             our @EXPORT_OK = qw(
178             $dec_number_rx $dec_integer_rx $dec_zero_rx $dec_one_rx $dec_negone_rx
179             is_dec_number check_dec_number
180             dec_canonise
181             dec_sgn dec_abs
182             dec_cmp dec_min dec_max
183             dec_neg dec_add dec_sub
184             dec_pow10 dec_mul_pow10
185             dec_mul
186             dec_rndiv_and_rem dec_rndiv dec_round_and_rem dec_round dec_rem
187             );
188              
189             eval { local $SIG{__DIE__};
190             require XSLoader;
191             XSLoader::load(__PACKAGE__, $VERSION);
192             };
193              
194             =head1 REGULAR EXPRESSIONS
195              
196             Each of these regular expressions matches some subset of numbers, in
197             the string form used by this module. The regular expressions do not
198             include any anchors, so to check whether an entire string matches a
199             number format you must supply the anchors yourself.
200              
201             =over
202              
203             =item $dec_number_rx
204              
205             Any number processed by this module. This checks the syntax in
206             which the number is expressed, without restricting its numeric value.
207             The number syntax consists of optional sign, one or more integer digits,
208             then optionally a dot (for the decimal point) and one or more fractional
209             digits. It is not permitted to have no integer digits, nor to have no
210             fractional digits if there is a decimal point. All digits must be ASCII
211             decimal digits. Unlike Perl's standard string-to-number conversions,
212             whitespace and other non-numeric parts are not permitted.
213              
214             =cut
215              
216             our $dec_number_rx = qr/[-+]?[0-9]+(?:\.[0-9]+)?/;
217              
218             =item $dec_integer_rx
219              
220             Any integer. This recognises integer values expressed in the
221             decimal format used by this module, I an integer-specific format.
222             So fractional decimal digits are allowed, provided that they are all zero,
223             as in "C<123.000>".
224              
225             =cut
226              
227             our $dec_integer_rx = qr/[-+]?[0-9]+(?:\.0+)?/;
228              
229             =item $dec_zero_rx
230              
231             Zero. This may have arbitrarily many integer and fractional digits,
232             and may be expressed with either sign.
233              
234             =cut
235              
236             our $dec_zero_rx = qr/[-+]?0+(?:\.0+)?/;
237              
238             =item $dec_one_rx
239              
240             Positive one.
241              
242             =cut
243              
244             our $dec_one_rx = qr/\+?0*1(?:\.0+)?/;
245              
246             =item $dec_negone_rx
247              
248             Negative one.
249              
250             =cut
251              
252             our $dec_negone_rx = qr/-0*1(?:\.0+)?/;
253              
254             =back
255              
256             =head1 FUNCTIONS
257              
258             Each C function takes one or more decimal arguments (I, I)
259             to operate on. If these arguments are not valid decimal numbers then
260             the function will C. Results are always returned as decimals in
261             minimum-length (canonical) form.
262              
263             =head2 Classification
264              
265             =over
266              
267             =item is_dec_number(ARG)
268              
269             Returns a truth value indicating whether I is a plain string
270             satisfying the decimal number syntax.
271              
272             =cut
273              
274 9   100 9 1 47 unless(defined &is_dec_number) { { local $SIG{__DIE__}; eval q{
  9     15404   19  
  9         639  
  15404         1338267  
275             sub is_dec_number($) {
276             no warnings "utf8";
277             return is_string($_[0]) && $_[0] =~ /\A$dec_number_rx\z/o;
278             }
279             }; } die $@ if $@ ne "" }
280              
281             =item check_dec_number(ARG)
282              
283             Checks whether I is a plain string satisfying the decimal number
284             syntax. Returns normally if it is. Cs if it is not.
285              
286             =cut
287              
288 15134 100   15134 1 392649 unless(defined &check_dec_number) { { local $SIG{__DIE__}; eval q{
289             sub check_dec_number($) {
290             croak "not a decimal number" unless &is_dec_number;
291             }
292             }; } die $@ if $@ ne "" }
293              
294             =back
295              
296             =head2 Representation
297              
298             =over
299              
300             =item dec_canonise(A)
301              
302             This returns the value I, numerically unmodified, but expressed
303             in minimum-length (canonical) form. Numerically this is the identity
304             function.
305              
306             =cut
307              
308 130298 100   130298 1 500494 unless(defined &dec_canonise) { { local $SIG{__DIE__}; eval q{
  130288 100       705829  
  130146 100       559247  
  130146 100       1625027  
    100          
309             sub dec_canonise($) {
310             croak "not a decimal number" unless is_string($_[0]);
311             $_[0] =~ /\A(?:(-)|\+?)0*([1-9][0-9]*|0)(?:(\.[0-9]*[1-9])0*|\.0+|)\z/
312             or croak "not a decimal number";
313             my $num = (defined($1) ? $1 : "").$2.(defined($3) ? $3 : "");
314             return $num eq "-0" ? "0" : $num;
315             }
316             }; } die $@ if $@ ne "" }
317              
318             =back
319              
320             =head2 Arithmetic
321              
322             =over
323              
324             =item dec_sgn(A)
325              
326             Returns +1 if the argument is positive, 0 if the argument is zero,
327             or -1 if the argument is negative.
328              
329             The value returned is not just a string, as usual for this module, but
330             has also been subjected to Perl's implicit numerification. This is
331             necessary for it to be an acceptable comparison value in a C
332             operation, on Perls prior to 5.11.0, due to perl bug #69384.
333              
334             =cut
335              
336             my @sgn_result = ("-1", "0", "1");
337             foreach(@sgn_result) {
338 18     18   8680 no warnings "void";
  18         39  
  18         16522  
339             $_ + 0;
340             }
341              
342 5981 100   5981 1 177682 unless(defined &dec_sgn) { { local $SIG{__DIE__}; eval q{
  5871 100       161872  
  5090 100       131045  
    100          
343             sub dec_sgn($) {
344             croak "not a decimal number" unless is_string($_[0]);
345             $_[0] =~ /\A(?:(-)|\+?)0*(?:0(?:\.0+)?()|[0-9]+(?:\.[0-9]+)?)\z/
346             or croak "not a decimal number";
347             return $sgn_result[defined($2) ? 1 : defined($1) ? 0 : 2];
348             }
349             }; } die $@ if $@ ne "" }
350              
351             =item dec_abs(A)
352              
353             Absolute value (magnitude, discarding sign).
354              
355             =cut
356              
357 4761 100   4761 1 56999 unless(defined &dec_abs) { { local $SIG{__DIE__}; eval q{
  4751         6437  
  4751         11521  
  4751         109454  
358             sub dec_abs($) {
359             croak "not a decimal number" unless is_string($_[0]);
360             my $a = $_[0];
361             $a =~ s/\A-(?=[0-9])//;
362             return dec_canonise($a);
363             }
364             }; } die $@ if $@ ne "" }
365              
366             =item dec_cmp(A, B)
367              
368             Arithmetic comparison. Returns -1, 0, or +1, indicating whether I is
369             less than, equal to, or greater than I.
370              
371             The value returned is not just a string, as usual for this module, but
372             has also been subjected to Perl's implicit numerification. This is
373             necessary for it to be an acceptable comparison value in a C
374             operation, on Perls prior to 5.11.0, due to perl bug #69384.
375              
376             =cut
377              
378 9 100 100 9 1 50 unless(defined &dec_cmp) { { local $SIG{__DIE__}; eval q{
  9 100 100 81393   14  
  9 100 100     4126  
  81393 100 100     10853984  
  81333 100       459645  
  81333 100       362920  
  81333 100       457000  
  80907 100       175968  
  80907 100       167391  
  80907 100       164408  
  80907 100       169527  
  80907 100       316423  
  80907 100       295060  
  80907 100       162307  
  80907         1615823  
  40267         59628  
  40267         101590  
  7771         24495  
  18840         39539  
  40267         56977  
  40267         99511  
  9642         16483  
  8452         13656  
  40267         96056  
  40267         1324578  
379             my %sgn_cmp = (
380             "+0" => "1",
381             "+-" => "1",
382             "0+" => "-1",
383             "00" => "0",
384             "0-" => "1",
385             "-+" => "-1",
386             "-0" => "-1",
387             );
388             foreach(values %sgn_cmp) {
389             no warnings "void";
390             $_ + 0;
391             }
392              
393             sub dec_cmp($$) {
394             croak "not a decimal number"
395             unless is_string($_[0]) && is_string($_[1]);
396             my($as, $ai, $af) = ($_[0] =~ /\A([-+])?([0-9]+)(?:\.([0-9]+))?\z/);
397             my($bs, $bi, $bf) = ($_[1] =~ /\A([-+])?([0-9]+)(?:\.([0-9]+))?\z/);
398             croak "not a decimal number" unless defined($ai) && defined($bi);
399             $as = "+" unless defined $as;
400             $bs = "+" unless defined $bs;
401             $af = "0" unless defined $af;
402             $bf = "0" unless defined $bf;
403             $as = "0" if $ai =~ /\A0+\z/ && $af =~ /\A0+\z/;
404             $bs = "0" if $bi =~ /\A0+\z/ && $bf =~ /\A0+\z/;
405             my $cmp = $sgn_cmp{$as.$bs};
406             return $cmp if defined $cmp;
407             my $ld = length($ai) - length($bi);
408             if($ld < 0) {
409             $ai = ("0" x -$ld) . $ai;
410             } elsif($ld > 0) {
411             $bi = ("0" x $ld) . $bi;
412             }
413             $ld = length($af) - length($bf);
414             if($ld < 0) {
415             $af .= "0" x -$ld;
416             } elsif($ld > 0) {
417             $bf .= "0" x $ld;
418             }
419             ($ai, $af, $bi, $bf) = ($bi, $bf, $ai, $af) if $as eq "-";
420             return $sgn_result[($ai.$af cmp $bi.$bf) + 1];
421             }
422             }; } die $@ if $@ ne "" }
423              
424             =item dec_min(A, B)
425              
426             Arithmetic minimum. Returns the arithmetically lesser of the two arguments.
427              
428             =cut
429              
430 20898 100   20898 1 631238 unless(defined &dec_min) { { local $SIG{__DIE__}; eval q{
431             sub dec_min($$) { dec_canonise($_[&dec_cmp eq "-1" ? 0 : 1]) }
432             }; } die $@ if $@ ne "" }
433              
434             =item dec_max(A, B)
435              
436             Arithmetic maximum. Returns the arithmetically greater of the two arguments.
437              
438             =cut
439              
440 20898 100   20898 1 10886885 unless(defined &dec_max) { { local $SIG{__DIE__}; eval q{
441             sub dec_max($$) { dec_canonise($_[&dec_cmp eq "1" ? 0 : 1]) }
442             }; } die $@ if $@ ne "" }
443              
444             =item dec_neg(A)
445              
446             Negation: returns -A.
447              
448             =cut
449              
450 14864     14864 1 73177 unless(defined &dec_neg) { { local $SIG{__DIE__}; eval q{
  14864         386208  
  14702         62408  
  14702         50377  
  14702         371033  
451             my %negate_sign = (
452             "" => "-",
453             "+" => "-",
454             "-" => "+",
455             );
456              
457             sub dec_neg($) {
458             my $a = $_[0];
459             check_dec_number($a);
460             $a =~ s/\A([-+]?)/$negate_sign{$1}/e;
461             return dec_canonise($a);
462             }
463             }; } die $@ if $@ ne "" }
464              
465             =item dec_add(A, B)
466              
467             Addition: returns A + B.
468              
469             =cut
470              
471 23400 100 100 23400 1 2294577 unless(defined &dec_add) { { local $SIG{__DIE__}; eval q{
  23370 100 100     130996  
  23370 100       106352  
  23370 100       132471  
  23157 100       51117  
  23157 100       52078  
  23157 100       43572  
  23157 100       43281  
  23157 100       24388  
  23157 100       35123  
  23157 100       61154  
  3022 100       7355  
  9835 100       22397  
  23157 100       30476  
  23157 100       58601  
  2538 100       4924  
  6343 100       12802  
  23157         26855  
  23157         39402  
  23157         28033  
  23157         42079  
  10843         11648  
  10843         16625  
  10843         24374  
  48433         83570  
  48433         78753  
  48433         86687  
  48433         112705  
  10843         314545  
  12314         31627  
  12314         13874  
  12314         18855  
  12314         28611  
  53839         97229  
  53839         80157  
  53839         93794  
  53839         131663  
  12314         368758  
472             sub dec_add($$) {
473             croak "not a decimal number"
474             unless is_string($_[0]) && is_string($_[1]);
475             my($as, $ai, $af) = ($_[0] =~ /\A([-+])?([0-9]+)(?:\.([0-9]+))?\z/);
476             my($bs, $bi, $bf) = ($_[1] =~ /\A([-+])?([0-9]+)(?:\.([0-9]+))?\z/);
477             croak "not a decimal number" unless defined($ai) && defined($bi);
478             $as = "+" unless defined $as;
479             $bs = "+" unless defined $bs;
480             $af = "0" unless defined $af;
481             $bf = "0" unless defined $bf;
482             {
483             my $ld = length($ai) - length($bi);
484             if($ld < 0) {
485             $ai = ("0" x -$ld) . $ai;
486             } elsif($ld > 0) {
487             $bi = ("0" x $ld) . $bi;
488             }
489             $ld = length($af) - length($bf);
490             if($ld < 0) {
491             $af .= "0" x -$ld;
492             } elsif($ld > 0) {
493             $bf .= "0" x $ld;
494             }
495             }
496             my $il = length($ai);
497             my $ad = $ai.$af;
498             my $bd = $bi.$bf;
499             if($as eq $bs) {
500             # same sign, add magnitudes
501             my $c = 0;
502             my $rd = " " x length($ad);
503             for(my $pos = length($ad); $pos--; ) {
504             my $rv = ord(substr($ad, $pos, 1)) +
505             (ord(substr($bd, $pos, 1)) - 0x30) + $c;
506             $c = $rv >= 0x3a ? 1 : 0;
507             $rv -= 10 if $c;
508             substr $rd, $pos, 1, chr($rv);
509             }
510             return dec_canonise($as.($c ? "1" : "").substr($rd, 0, $il).
511             ".".substr($rd, $il));
512             } else {
513             # different sign, subtract magnitudes
514             ($as, $ad, $bd) = ($bs, $bd, $ad) if $ad lt $bd;
515             my $c = 0;
516             my $rd = " " x length($ad);
517             for(my $pos = length($ad); $pos--; ) {
518             my $rv = ord(substr($ad, $pos, 1)) -
519             (ord(substr($bd, $pos, 1)) - 0x30) - $c;
520             $c = $rv < 0x30 ? 1 : 0;
521             $rv += 10 if $c;
522             substr $rd, $pos, 1, chr($rv);
523             }
524             return dec_canonise($as.substr($rd, 0, $il).
525             ".".substr($rd, $il));
526             }
527             }
528             }; } die $@ if $@ ne "" }
529              
530             =item dec_sub(A, B)
531              
532             Subtraction: returns A - B.
533              
534             =cut
535              
536 12367     12367 1 5171595 unless(defined &dec_sub) { { local $SIG{__DIE__}; eval q{
537             sub dec_sub($$) { dec_add($_[0], dec_neg($_[1])) }
538             }; } die $@ if $@ ne "" }
539              
540             =item dec_pow10(A)
541              
542             Power of ten: returns 10^A.
543             I must be an integer value (though it has the usual decimal syntax).
544             Cs if I is too large for Perl to handle the result.
545              
546             =cut
547              
548             unless(defined(&dec_pow10) && defined(&dec_mul_pow10)) {
549 20264 100 100 20264   53190 { local $SIG{__DIE__}; eval q{
  20244 100       97849  
  20244 100       71861  
  20102 100       45624  
  20092 100       52381  
  20088         566265  
550             sub _parse_expt($) {
551             croak "not a decimal number" unless is_string($_[0]);
552             my($pneg, $pi, $pbadf) =
553             ($_[0] =~ /\A(?:(-)|\+?)
554             0*(0|[1-9][0-9]*)
555             (?:|\.0+|\.[0-9]+())\z/x);
556             croak "not a decimal number" unless defined $pi;
557             croak "not an integer" if defined $pbadf;
558             croak "exponent too large" if length($pi) > 9;
559             return defined($pneg) && $pi ne "0" ? 0-$pi : 0+$pi;
560             }
561             }; } die $@ if $@ ne "" }
562              
563 198 100   198 1 93149 unless(defined &dec_pow10) { { local $SIG{__DIE__}; eval q{
  110         209  
  28         126  
  82         321  
564             sub dec_pow10($) {
565             my $p = &_parse_expt;
566             if($p < 0) {
567             return "0.".("0" x (-1-$p))."1";
568             } else {
569             return "1".("0" x $p);
570             }
571             }
572             }; } die $@ if $@ ne "" }
573              
574             =item dec_mul_pow10(A, B)
575              
576             Digit shifting: returns A * 10^B.
577             I must be an integer value (though it has the usual decimal syntax).
578             Cs if I is too large for Perl to handle the result.
579              
580             =cut
581              
582 20147 100   20147 1 7223062 unless(defined &dec_mul_pow10) { { local $SIG{__DIE__}; eval q{
  20137 100       116187  
  20137 100       63458  
  20066 100       38560  
  20066 100       504123  
  19978 100       42811  
  4293         5461  
  4293         15346  
  4293         112782  
  15685         20244  
  15685         42072  
  15685         418428  
583             sub dec_mul_pow10($$) {
584             croak "not a decimal number" unless is_string($_[0]);
585             my($as, $ai, $af) = ($_[0] =~ /\A([-+]?)([0-9]+)(?:\.([0-9]+))?\z/);
586             croak "not a decimal number" unless defined $ai;
587             $af = "" unless defined $af;
588             my $p = _parse_expt($_[1]);
589             if($p < 0) {
590             my $il = length($ai);
591             $ai = ("0" x (1-$p-$il)).$ai if $il+$p <= 0;
592             return dec_canonise($as.substr($ai, 0, $p).".".
593             substr($ai, $p).$af);
594             } else {
595             my $fl = length($af);
596             $af .= "0" x (1+$p-$fl) if $p >= $fl;
597             return dec_canonise($as.$ai.substr($af, 0, $p).".".
598             substr($af, $p));
599             }
600             }
601             }; } die $@ if $@ ne "" }
602              
603             =item dec_mul(A, B)
604              
605             Multiplication: returns A * B.
606              
607             =cut
608              
609 9 100 100 9 1 8888 unless(defined &dec_mul) { { local $SIG{__DIE__}; eval q{
  9 100 100 9   333  
  9 100   26175   44  
  9 100       584  
  9 100       14  
  9 100       33  
  26175 100       2212389  
  26155 100       147689  
  26155         107110  
  26155         141120  
  26013         55453  
  26013         58510  
  26013         54451  
  26013         49748  
  26013         38869  
  26013         37356  
  26013         30829  
  26013         27642  
  26013         26332  
  26013         41320  
  26013         67583  
  58669         84245  
  58669         152110  
  28723         31124  
  28723         62989  
  58136         65873  
  58136         75058  
  58136         96404  
  58136         62953  
  58136         96807  
  58136         59711  
  58136         139138  
  28723         83930  
  26013         753962  
610             sub dec_mul($$) {
611             croak "not a decimal number"
612             unless is_string($_[0]) && is_string($_[1]);
613             my($as, $ai, $af) =
614             ($_[0] =~ /\A([-+])?0*(0|[1-9][0-9]*)(?:\.([0-9]+))?\z/);
615             my($bs, $bi, $bf) =
616             ($_[1] =~ /\A([-+])?0*(0|[1-9][0-9]*)(?:\.([0-9]+))?\z/);
617             croak "not a decimal number" unless defined($ai) && defined($bi);
618             $as = "+" unless defined $as;
619             $bs = "+" unless defined $bs;
620             $af = "" unless defined $af;
621             $bf = "0" unless defined $bf;
622             my $il = length($ai) + length($bi);
623             my $ad = $ai.$af;
624             my $bd = $bi.$bf;
625             my $al = length($ad);
626             my $bl = length($bd);
627             my $rd = "0" x ($al+$bl);
628             for(my $bp = $bl; $bp--; ) {
629             my $bv = ord(substr($bd, $bp, 1)) - 0x30;
630             next if $bv == 0;
631             my $c = 0;
632             for(my $ap = $al; $ap--; ) {
633             my $rp = $ap + $bp + 1;
634             my $av = ord(substr($ad, $ap, 1)) - 0x30;
635             my $v = $av*$bv + $c + ord(substr($rd, $rp, 1)) - 0x30;
636             substr $rd, $rp, 1,
637             chr(do { use integer; $v%10 + 0x30 });
638             $c = do { use integer; $v / 10 };
639             }
640             substr $rd, $bp, 1, chr(ord(substr($rd, $bp, 1)) + $c);
641             }
642             return dec_canonise(($as eq $bs ? "+" : "-").substr($rd, 0, $il).
643             ".".substr($rd, $il));
644             }
645             }; } die $@ if $@ ne "" }
646              
647             =item dec_rndiv_and_rem(MODE, A, B)
648              
649             Rounding division: returns a list of two items, the quotient (I) and
650             remainder (I) from the division of I by I.
651             The quotient is by definition
652             integral, and the quantities are related by the equation Q*B + R = A.
653             I controls the rounding mode, which determines which integer I is
654             when I is non-zero.
655              
656             =cut
657              
658 4464 100 100 4464 1 14213 unless(defined &dec_rndiv_and_rem) { { local $SIG{__DIE__}; eval q{
  4434 100 100 6244   8819  
  4424 100       11818  
  4424 100       12915  
  4424 100       9238  
  4424 100       10894  
  4424 100       5742  
  4424 100       5034  
  4424 100       11950  
  4912 100       69361  
  4912 100       9551  
  35940 100       460487  
  35940 100       474763  
  4912         64394  
  4912         62707  
  4912         19747  
  4424         12978  
  6244         1978873  
  6244         56004  
  6084         93048  
  5274         85538  
  4464         66125  
  4464         63116  
  4464         10312  
  4434         14622  
  4434         6556  
  4434         47676  
  1440         19554  
  1440         18971  
  4432         111603  
659              
660             sub _nonneg_rndiv_and_rem_twz($$) {
661             croak "division by zero" if $_[1] eq "0";
662             return ("0", "0") if $_[0] eq "0";
663             $_[0] =~ /\A(?:[1-9]([0-9]*)|0\.(0*)[1-9])/;
664             my $a_expt = defined($1) ? length($1) : -1-length($2);
665             $_[1] =~ /\A(?:[1-9]([0-9]*)|0\.(0*)[1-9])/;
666             my $b_expt = defined($1) ? length($1) : -1-length($2);
667             my $q = "0";
668             my $r = $_[0];
669             for(my $s = $a_expt-$b_expt; $s >= 0; $s--) {
670             my $sd = dec_mul_pow10($_[1], $s);
671             for(my $m = 9; ; $m--) {
672             my $msd = dec_mul($sd, $m);
673             if(dec_cmp($msd, $r) ne "1") {
674             $q = dec_add($q, dec_mul_pow10($m, $s));
675             $r = dec_sub($r, $msd);
676             last;
677             }
678             }
679             }
680             return ($q, $r);
681             }
682              
683             my %round_tiebreak = (
684             (map { ($_ => $_, "NEAR_$_" => $_) } qw(TWZ AWZ FLR CLG EVN ODD)),
685             EXACT => "EXACT",
686             );
687              
688             my %round_positive = (
689             (map { my($f, $t) = split(/:/, $_); ($f => $t, "NEAR_$f" => "NEAR_$t") }
690             qw(TWZ:TWZ AWZ:AWZ FLR:TWZ CLG:AWZ EVN:EVN ODD:ODD)),
691             EXACT => "EXACT",
692             );
693              
694             my %round_negative = (
695             (map { my($f, $t) = split(/:/, $_); ($f => $t, "NEAR_$f" => "NEAR_$t") }
696             qw(TWZ:TWZ AWZ:AWZ FLR:AWZ CLG:TWZ EVN:EVN ODD:ODD)),
697             EXACT => "EXACT",
698             );
699              
700             my %base_round_handler = (
701             TWZ => sub { 0 },
702             AWZ => sub { 1 },
703             EVN => sub { $_[0] =~ /[13579]\z/ },
704             ODD => sub { $_[0] =~ /[02468]\z/ },
705             );
706              
707             sub dec_rndiv_and_rem($$$) {
708             my $mode = $_[0];
709             croak "invalid rounding mode"
710             unless is_string($mode) && exists($round_tiebreak{$mode});
711             my $sgn_a = dec_sgn($_[1]);
712             my $sgn_b = dec_sgn($_[2]);
713             my $abs_a = dec_abs($_[1]);
714             my $abs_b = dec_abs($_[2]);
715             my($q, $r) = _nonneg_rndiv_and_rem_twz($abs_a, $abs_b);
716             $mode = ($sgn_a == $sgn_b ? \%round_positive : \%round_negative)
717             ->{$mode};
718             my $half_cmp;
719             if(
720             $r eq "0" ? 0 :
721             $mode eq "EXACT" ? croak("inexact division") :
722             $mode =~ /\ANEAR_/ &&
723             ($half_cmp = dec_cmp(dec_mul($r, "2"), $abs_b))
724             ne "0" ?
725             $half_cmp eq "1" :
726             $base_round_handler{$round_tiebreak{$mode}}->($q)
727             ) {
728             $q = dec_add($q, "1");
729             $r = dec_sub($r, $abs_b);
730             }
731             return (($sgn_a ne $sgn_b ? dec_neg($q) : $q),
732             ($sgn_a ne "1" ? dec_neg($r) : $r));
733             }
734              
735             }; } die $@ if $@ ne "" }
736              
737             =item dec_rndiv(MODE, A, B)
738              
739             Rounding division: returns the quotient (I)
740             from the division of I by I.
741             The quotient is by definition integral, and approximates A/B. I
742             controls the rounding mode, which determines which integer I is when it
743             can't be exactly A/B.
744              
745             =cut
746              
747 1252     1252 1 254449 unless(defined &dec_rndiv) { { local $SIG{__DIE__}; eval q{
  888         5381  
748             sub dec_rndiv($$$) {
749             my($quotient, undef) = &dec_rndiv_and_rem;
750             return $quotient;
751             }
752             }; } die $@ if $@ ne "" }
753              
754             =item dec_round_and_rem(MODE, A, B)
755              
756             Rounding: returns a list of two items, the rounded value (I) and remainder
757             (I) from the rounding of I to a multiple of I. The rounded value is
758             an exact multiple of I, and the quantities are related by the equation
759             V + R = A. I controls the rounding mode, which determines which
760             multiple of I I is when I is non-zero.
761              
762             =cut
763              
764 1248     1248 1 261531 unless(defined &dec_round_and_rem) { { local $SIG{__DIE__}; eval q{
  886         15768  
765             sub dec_round_and_rem($$$) {
766             my($quotient, $remainder) = &dec_rndiv_and_rem;
767             return (dec_mul($_[2], $quotient), $remainder);
768             }
769             }; } die $@ if $@ ne "" }
770              
771             =item dec_round(MODE, A, B)
772              
773             Rounding: returns the rounded value (I) from the rounding of I to
774             a multiple of I. The rounded value is an exact multiple of I, and
775             approximates I. I controls the rounding mode, which determines
776             which multiple of I I is when it can't be exactly I.
777              
778             =cut
779              
780 1248     1248 1 256636 unless(defined &dec_round) { { local $SIG{__DIE__}; eval q{
  886         13459  
781             sub dec_round($$$) {
782             my($quotient, undef) = &dec_rndiv_and_rem;
783             return dec_mul($_[2], $quotient);
784             }
785             }; } die $@ if $@ ne "" }
786              
787             =item dec_rem(MODE, A, B)
788              
789             Remainder: returns the remainder (I) from the division of I by I.
790             I differs from I by an exact multiple of I.
791             I controls the rounding
792             mode, which determines which quotient is used when I is non-zero.
793              
794             =cut
795              
796 1248     1248 1 271195 unless(defined &dec_rem) { { local $SIG{__DIE__}; eval q{
  886         5461  
797             sub dec_rem($$$) {
798             my(undef, $remainder) = &dec_rndiv_and_rem;
799             return $remainder;
800             }
801             }; } die $@ if $@ ne "" }
802              
803             =back
804              
805             =head1 BUGS
806              
807             The implementation of division is hideously inefficient.
808             This should be improved in a future version.
809              
810             =head1 SEE ALSO
811              
812             L
813              
814             =head1 AUTHOR
815              
816             Andrew Main (Zefram)
817              
818             =head1 COPYRIGHT
819              
820             Copyright (C) 2009, 2010, 2011 Andrew Main (Zefram)
821              
822             =head1 LICENSE
823              
824             This module is free software; you can redistribute it and/or modify it
825             under the same terms as Perl itself.
826              
827             =cut
828              
829             1;