1 package SL::Helper::Number;
4 use Exporter qw(import);
5 use List::Util qw(max min);
13 our %EXPORT_TAGS = (all => \@EXPORT_OK);
16 my ($myconfig, $amount, $places, $dash) = @_;
19 my $neg = $amount < 0;
20 my $force_places = defined $places && $places >= 0;
22 $amount = _round_number($amount, abs $places) if $force_places;
23 $neg = 0 if $amount == 0; # don't show negative zero
24 $amount = sprintf "%.*f", ($force_places ? $places : 10), abs $amount; # 6 is default for %fa
26 # before the sprintf amount was a number, afterwards it's a string. because of the dynamic nature of perl
27 # this is easy to confuse, so keep in mind: before this comment no s///, m//, concat or other strong ops on
28 # $amount. after this comment no +,-,*,/,abs. it will only introduce subtle bugs.
30 $amount =~ s/0*$// unless defined $places && $places == 0; # cull trailing 0s
32 my @d = map { s/\d//g; reverse split // } my $tmp = $myconfig->{numberformat}; # get delim chars
33 my @p = split(/\./, $amount); # split amount at decimal point
35 $p[0] =~ s/\B(?=(...)*$)/$d[1]/g if $d[1]; # add 1,000 delimiters
37 if ($places || $p[1]) {
40 . (0 x max(abs($places || 0) - length ($p[1]||''), 0)); # pad the fraction
44 ($dash =~ /-/) ? ($neg ? "($amount)" : "$amount" ) :
45 ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) :
46 ($neg ? "-$amount" : "$amount" ) ;
53 my ($amount, $places, $adjust) = @_;
55 return 0 if !defined $amount;
60 my $precision = $::instance_conf->get_precision || 0.01;
61 return _round_number( _round_number($amount / $precision, 0) * $precision, $places);
64 # We use Perl's knowledge of string representation for
65 # rounding. First, convert the floating point number to a string
66 # with a high number of places. Then split the string on the decimal
67 # sign and use integer calculation for rounding the decimal places
68 # part. If an overflow occurs then apply that overflow to the part
69 # before the decimal sign as well using integer arithmetic again.
71 my $int_amount = int(abs $amount);
72 my $str_places = max(min(10, 16 - length("$int_amount") - $places), $places);
73 my $amount_str = sprintf '%.*f', $places + $str_places, abs($amount);
75 return $amount unless $amount_str =~ m{^(\d+)\.(\d+)$};
77 my ($pre, $post) = ($1, $2);
78 my $decimals = '1' . substr($post, 0, $places);
80 my $propagation_limit = $Config{i32size} == 4 ? 7 : 18;
81 my $add_for_rounding = substr($post, $places, 1) >= 5 ? 1 : 0;
83 if ($places > $propagation_limit) {
84 $decimals = Math::BigInt->new($decimals)->badd($add_for_rounding);
85 $pre = Math::BigInt->new($decimals)->badd(1) if substr($decimals, 0, 1) eq '2';
88 $decimals += $add_for_rounding;
89 $pre += 1 if substr($decimals, 0, 1) eq '2';
92 $amount = ("${pre}." . substr($decimals, 1)) * ($amount <=> 0);
98 my ($myconfig, $amount) = @_;
100 return 0 if !defined $amount || $amount eq '';
102 if ( ($myconfig->{numberformat} eq '1.000,00')
103 || ($myconfig->{numberformat} eq '1000,00')) {
108 if ($myconfig->{numberformat} eq "1'000.00") {
114 # Make sure no code wich is not a math expression ends up in eval().
115 return 0 unless $amount =~ /^ [\s \d \( \) \- \+ \* \/ \. ]* $/x;
117 # Prevent numbers from being parsed as octals;
118 $amount =~ s{ (?<! [\d.] ) 0+ (?= [1-9] ) }{}gx;
120 return scalar(eval($amount)) * 1 ;
123 sub _total { _number(\%::myconfig, $_[0], 2) }
125 sub _round_total { _round_number($_[0], 2) }
135 SL::Helper::Number - number formating functions formerly sitting in SL::Form
139 use SL::Helper::Number qw(all);
141 my $str = _number(\%::myconfig, $val, 2);
142 my $total = _total($val); # rounded to 2
144 my $val = _parse_number(\%::myconfig, $str);
146 my $str = _round_number(\%::myconfig, $val, 2);
147 my $total = _round_total($val); # rounded to 2
151 This package contains all the number parsing/formating functions that were previously in SL::Form.
153 Instead of invoking them as methods on C<$::form> these are pure functions.
159 =item * C<_number MYCONFIG VALUE PLACES DASH>
161 The old C<SL::Form::format_amount>. C<MYCONFIG> is expected to be a hashref
162 with a C<numberformat> entry. Usually C<\%::myconfig> will be passed.
164 The value is expected to be a numeric value, but undef and empty string will be
165 vivified to 0 for convinience. Bigints are supported.
167 For the semantics of places, see L</PLACES>.
169 The dash parameter allows to change the formatting of positive and negative
170 numbers to alternative ones. If C<-> is given for dash, negative numbers will
171 instead be formatted with prentheses. If C<DRCR> is given, the numbers will be
172 formatted absolute, but suffixed with the localized versions of C<DR> and
177 A curried version used for formatting ledger entries. C<myconfig> is set from the
178 current user, C<places> is set to 2. C<dash> is left empty.
180 =item * _parse_number MYCONFIG VALUE
182 Parses expressions into numbers. C<MYCONFIG> is expected to be a hashref
183 with a C<numberformat> entry.
185 Also implements basic arithmetic interprtation, so that C<2 * 1400> is
188 =item * _round_number VALUE PLACES
190 Rounds a number. Due to the way Perl handles floating point we take a lot of
191 precautions that rounding ends up being close to where we want. Usually the
192 internal floats have more than enough precision to not have any floating point
193 issues, but the cumulative error can interfere with proper formatting later.
195 For places, see L</PLACES>
199 A curried version used for rounding ledger entries. C<places> is set to 2.
211 In that case a representation is chosen that looks sufficiently human. For
212 example C<1/10> equals C<.1000000000000000555> but will be displayed as the
213 localzed version of 0.1.
217 The number will be rounded to the nearest integer (towards 0).
219 =item * a positive integer
221 The number will be rounded to this many places. Formatting functions will then
222 make sure to pad the output to this many places.
224 =item * a negative inteher
226 The number will not be rounded, but padded to at least this many places.
230 =head1 ERROR REPORTING
232 All of these do not thow exceptions and will simply return undef should
233 something unforeseen happen.
235 =head1 BUGS AND CAVEATS
237 Beware that the old C<amount> is now called plain C<number>. C<amount> is
238 deliberately unused in the new version for that reason.
242 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>