Vertreter-Funktion: Im Kundenstamm ausgebaut und Hinweis in M-Konfig
[kivitendo-erp.git] / SL / Helper / Number.pm
1 package SL::Helper::Number;
2
3 use strict;
4 use Exporter qw(import);
5 use List::Util qw(max min);
6 use List::UtilsBy qw(rev_nsort_by);
7 use Config;
8
9 our @EXPORT_OK = qw(
10   _format_number _round_number
11   _format_total  _round_total
12   _parse_number
13 );
14 our %EXPORT_TAGS = (ALL => \@EXPORT_OK);
15
16 sub _format_number {
17   my ($amount, $places, %params) = @_;
18   $amount        ||= 0;
19   my $dash         = $params{dash} // '';
20   my $numberformat = $params{numberformat} // $::myconfig{numberformat};
21   my $neg          = $amount < 0;
22   my $force_places = defined $places && $places >= 0;
23
24   $amount = _round_number($amount, abs $places) if $force_places;
25   $neg    = 0 if $amount == 0; # don't show negative zero
26   $amount = sprintf "%.*f", ($force_places ? $places : 10), abs $amount; # 6 is default for %fa
27
28   # before the sprintf amount was a number, afterwards it's a string. because of the dynamic nature of perl
29   # this is easy to confuse, so keep in mind: before this comment no s///, m//, concat or other strong ops on
30   # $amount. after this comment no +,-,*,/,abs. it will only introduce subtle bugs.
31
32   $amount =~ s/0*$// unless defined $places && $places == 0;             # cull trailing 0s
33
34   my @d = reverse $numberformat =~ /(\D)/g;                              # get delim chars
35   my @p = split(/\./, $amount);                                          # split amount at decimal point
36
37   $p[0] =~ s/\B(?=(...)*$)/$d[1]/g if $d[1];                             # add 1,000 delimiters
38   $amount = $p[0];
39   if ($places || $p[1]) {
40     $amount .= $d[0]
41             .  ( $p[1] || '' )
42             .  (0 x max(abs($places || 0) - length ($p[1]||''), 0));     # pad the fraction
43   }
44
45   $amount = do {
46     ($dash =~ /-/)    ? ($neg ? "($amount)"                            : "$amount" )                              :
47     ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) :
48                         ($neg ? "-$amount"                             : "$amount" )                              ;
49   };
50
51   $amount;
52 }
53
54 sub _round_number {
55   my ($amount, $places, $adjust) = @_;
56
57   return 0 if !defined $amount;
58
59   $places //= 0;
60
61   if ($adjust) {
62     no warnings 'once';
63     my $precision = $::instance_conf->get_precision || 0.01;
64     return _round_number( _round_number($amount / $precision, 0) * $precision, $places);
65   }
66
67   # We use Perl's knowledge of string representation for
68   # rounding. First, convert the floating point number to a string
69   # with a high number of places. Then split the string on the decimal
70   # sign and use integer calculation for rounding the decimal places
71   # part. If an overflow occurs then apply that overflow to the part
72   # before the decimal sign as well using integer arithmetic again.
73
74   my $int_amount = int(abs $amount);
75   my $str_places = max(min(10, 16 - length("$int_amount") - $places), $places);
76   my $amount_str = sprintf '%.*f', $places + $str_places, abs($amount);
77
78   return $amount unless $amount_str =~ m{^(\d+)\.(\d+)$};
79
80   my ($pre, $post)      = ($1, $2);
81   my $decimals          = '1' . substr($post, 0, $places);
82
83   my $propagation_limit = $Config{i32size} == 4 ? 7 : 18;
84   my $add_for_rounding  = substr($post, $places, 1) >= 5 ? 1 : 0;
85
86   if ($places > $propagation_limit) {
87     $decimals = Math::BigInt->new($decimals)->badd($add_for_rounding);
88     $pre      = Math::BigInt->new($decimals)->badd(1) if substr($decimals, 0, 1) eq '2';
89
90   } else {
91     $decimals += $add_for_rounding;
92     $pre      += 1 if substr($decimals, 0, 1) eq '2';
93   }
94
95   $amount  = ("${pre}." . substr($decimals, 1)) * ($amount <=> 0);
96
97   return $amount;
98 }
99
100 sub _parse_number {
101   my ($amount, %params) = @_;
102
103   return 0 if !defined $amount || $amount eq '';
104
105   my $numberformat = $params{numberformat} // $::myconfig{numberformat};
106
107   if (   ($numberformat eq '1.000,00')
108       || ($numberformat eq '1000,00')) {
109     $amount =~ s/\.//g;
110     $amount =~ s/,/\./g;
111   }
112
113   if ($numberformat eq "1'000.00") {
114     $amount =~ s/\'//g;
115   }
116
117   $amount =~ s/,//g;
118
119   # Make sure no code wich is not a math expression ends up in eval().
120   return 0 unless $amount =~ /^ [\s \d \( \) \- \+ \* \/ \. ]* $/x;
121
122   # Prevent numbers from being parsed as octals;
123   $amount =~ s{ (?<! [\d.] ) 0+ (?= [1-9] ) }{}gx;
124
125   return scalar(eval($amount)) * 1 ;
126 }
127
128 sub _format_total    { _format_number($_[0], 2, @_[1..$#_])  }
129 sub _round_total    { _round_number($_[0], 2, @_[1..$#_]) }
130
131 1;
132
133 __END__
134
135 =encoding utf-8
136
137 =head1 NAME
138
139 SL::Helper::Number - number formating functions formerly sitting in SL::Form
140
141 =head1 SYNOPSIS
142
143   use SL::Helper::Number qw(all);
144
145   my $str       = _format_number($val, 2); # round to 2
146   my $str       = _format_number($val, 2, %::myconfig);                # also works, is implied
147   my $str       = _format_number($val, 2, numberformat => '1.000,00'); # with custom numberformat
148   my $total     = _format_total($val);     # round to 2
149   my $total     = _format_total($val, numberformat => '1.000,00');
150
151   my $val       = _parse_number($str);                             # parse with the current numberformat
152   my $val       = _parse_number($str, numberformat => '1.000,00'); # parse with the current numberformat
153
154   my $str       = _round_number($val, 2);
155   my $total     = _round_total($val);     # rounded to 2
156
157 =head1 DESCRIPTION
158
159 This package contains all the number parsing/formating functions that were
160 previously in SL::Form.
161
162 Instead of invoking them as methods on C<$::form> these are pure functions.
163
164 =head1 FUNCTIONS
165
166 =over 4
167
168 =item * C<_format_number VALUE PLACES PARAMS>
169
170 The old C<SL::Form::format_amount> with a different signature.
171
172 The value is expected to be a numeric value, but undef and empty string will be
173 vivified to 0 for convinience. Bigints are supported.
174
175 For the semantics of places, see L</PLACES>.
176
177 If C<params> contains a dash parameter, it will change the formatting of
178 positive/negative numbers. If C<-> is given for dash, negative numbers will
179 instead be formatted with prentheses. If C<DRCR> is given, the numbers will be
180 formatted absolute, but suffixed with the localized versions of C<DR> and
181 C<CR>.
182
183 =item * _format_total
184
185 A curried version used for formatting ledger entries. C<myconfig> is set from the
186 current user, C<places> is set to 2. C<dash> is left empty.
187
188 =item * _parse_number VALUE PARAMS
189
190 Parses expressions into numbers. C<PARAMS> may contain C<numberformat> just
191 like with C<L/_format_amount>.
192
193 Also implements basic arithmetic interpretation, so that C<2 * 1400> is
194 interpreted as 2800.
195
196 =item * _round_number VALUE PLACES
197
198 Rounds a number. Due to the way Perl handles floating point we take a lot of
199 precautions that rounding ends up being close to where we want. Usually the
200 internal floats have more than enough precision to not have any floating point
201 issues, but the cumulative error can interfere with proper formatting later.
202
203 For places, see L</PLACES>
204
205 =item * _round_total
206
207 A curried version used for rounding ledger entries. C<places> is set to 2.
208
209 =back
210
211 =head1 PLACES
212
213 Places can be:
214
215 =over 4
216
217 =item * not present
218
219 In that case a representation is chosen that looks sufficiently human. For
220 example C<1/10> equals C<.1000000000000000555> but will be displayed as the
221 localized version of 0.1.
222
223 =item * 0
224
225 The number will be rounded to the nearest integer (towards 0).
226
227 =item * a positive integer
228
229 The number will be rounded to this many places. Formatting functions will then
230 make sure to pad the output to this many places.
231
232 =item * a negative inteher
233
234 The number will not be rounded, but padded to at least this many places.
235
236 =back
237
238 =head1 ERROR REPORTING
239
240 All of these do not thow exceptions and will simply return undef should
241 something unforeseen happen.
242
243 =head1 BUGS AND CAVEATS
244
245 Beware that the old C<amount> is now called plain C<number>. C<amount> is
246 deliberately unused in the new version for that reason.
247
248 =head1 AUTHOR
249
250 Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
251
252 =cut