use Data::Dumper;
use Carp;
-use Config;
use CGI;
use Cwd;
use Encode;
use List::MoreUtils qw(all any apply);
use SL::DB::Tax;
use SL::Helper::File qw(:all);
+use SL::Helper::Number;
use SL::Helper::CreatePDF qw(merge_pdfs);
use strict;
return @columns;
}
#
-sub format_amount {
- $main::lxdebug->enter_sub(2);
+sub format_amount {
my ($self, $myconfig, $amount, $places, $dash) = @_;
- $amount ||= 0;
- $dash ||= '';
- my $neg = $amount < 0;
- my $force_places = defined $places && $places >= 0;
-
- $amount = $self->round_amount($amount, abs $places) if $force_places;
- $neg = 0 if $amount == 0; # don't show negative zero
- $amount = sprintf "%.*f", ($force_places ? $places : 10), abs $amount; # 6 is default for %fa
-
- # before the sprintf amount was a number, afterwards it's a string. because of the dynamic nature of perl
- # this is easy to confuse, so keep in mind: before this comment no s///, m//, concat or other strong ops on
- # $amount. after this comment no +,-,*,/,abs. it will only introduce subtle bugs.
-
- $amount =~ s/0*$// unless defined $places && $places == 0; # cull trailing 0s
-
- my @d = map { s/\d//g; reverse split // } my $tmp = $myconfig->{numberformat}; # get delim chars
- my @p = split(/\./, $amount); # split amount at decimal point
-
- $p[0] =~ s/\B(?=(...)*$)/$d[1]/g if $d[1]; # add 1,000 delimiters
- $amount = $p[0];
- if ($places || $p[1]) {
- $amount .= $d[0]
- . ( $p[1] || '' )
- . (0 x max(abs($places || 0) - length ($p[1]||''), 0)); # pad the fraction
- }
-
- $amount = do {
- ($dash =~ /-/) ? ($neg ? "($amount)" : "$amount" ) :
- ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) :
- ($neg ? "-$amount" : "$amount" ) ;
- };
-
- $main::lxdebug->leave_sub(2);
- return $amount;
+ SL::Helper::Number::_format_number($amount, $places, %$myconfig, dash => $dash);
}
sub format_amount_units {
#
sub parse_amount {
- $main::lxdebug->enter_sub(2);
-
my ($self, $myconfig, $amount) = @_;
-
- if (!defined($amount) || ($amount eq '')) {
- $main::lxdebug->leave_sub(2);
- return 0;
- }
-
- if ( ($myconfig->{numberformat} eq '1.000,00')
- || ($myconfig->{numberformat} eq '1000,00')) {
- $amount =~ s/\.//g;
- $amount =~ s/,/\./g;
- }
-
- if ($myconfig->{numberformat} eq "1'000.00") {
- $amount =~ s/\'//g;
- }
-
- $amount =~ s/,//g;
-
- $main::lxdebug->leave_sub(2);
-
- # Make sure no code wich is not a math expression ends up in eval().
- return 0 unless $amount =~ /^ [\s \d \( \) \- \+ \* \/ \. ]* $/x;
-
- # Prevent numbers from being parsed as octals;
- $amount =~ s{ (?<! [\d.] ) 0+ (?= [1-9] ) }{}gx;
-
- return scalar(eval($amount)) * 1 ;
+ SL::Helper::Number::_parse_number($amount, %$myconfig);
}
-sub round_amount {
- my ($self, $amount, $places, $adjust) = @_;
-
- return 0 if !defined $amount;
-
- $places //= 0;
-
- if ($adjust) {
- my $precision = $::instance_conf->get_precision || 0.01;
- return $self->round_amount( $self->round_amount($amount / $precision, 0) * $precision, $places);
- }
-
- # We use Perl's knowledge of string representation for
- # rounding. First, convert the floating point number to a string
- # with a high number of places. Then split the string on the decimal
- # sign and use integer calculation for rounding the decimal places
- # part. If an overflow occurs then apply that overflow to the part
- # before the decimal sign as well using integer arithmetic again.
-
- my $int_amount = int(abs $amount);
- my $str_places = max(min(10, 16 - length("$int_amount") - $places), $places);
- my $amount_str = sprintf '%.*f', $places + $str_places, abs($amount);
-
- return $amount unless $amount_str =~ m{^(\d+)\.(\d+)$};
-
- my ($pre, $post) = ($1, $2);
- my $decimals = '1' . substr($post, 0, $places);
-
- my $propagation_limit = $Config{i32size} == 4 ? 7 : 18;
- my $add_for_rounding = substr($post, $places, 1) >= 5 ? 1 : 0;
-
- if ($places > $propagation_limit) {
- $decimals = Math::BigInt->new($decimals)->badd($add_for_rounding);
- $pre = Math::BigInt->new($decimals)->badd(1) if substr($decimals, 0, 1) eq '2';
-
- } else {
- $decimals += $add_for_rounding;
- $pre += 1 if substr($decimals, 0, 1) eq '2';
- }
-
- $amount = ("${pre}." . substr($decimals, 1)) * ($amount <=> 0);
-
- return $amount;
-}
+sub round_amount { shift; goto &SL::Helper::Number::_round_number; }
sub parse_template {
$main::lxdebug->enter_sub();
--- /dev/null
+package SL::Helper::Number;
+
+use strict;
+use Exporter qw(import);
+use List::Util qw(max min);
+use Config;
+
+our @EXPORT_OK = qw(
+ _format_number _round_number
+ _format_total _round_total
+ _parse_number
+);
+our %EXPORT_TAGS = (ALL => \@EXPORT_OK);
+
+sub _format_number {
+ my ($amount, $places, %params) = @_;
+ $amount ||= 0;
+ my $dash = $params{dash} // '';
+ my $numberformat = $params{numberformat} // $::myconfig{numberformat};
+ my $neg = $amount < 0;
+ my $force_places = defined $places && $places >= 0;
+
+ $amount = _round_number($amount, abs $places) if $force_places;
+ $neg = 0 if $amount == 0; # don't show negative zero
+ $amount = sprintf "%.*f", ($force_places ? $places : 10), abs $amount; # 6 is default for %fa
+
+ # before the sprintf amount was a number, afterwards it's a string. because of the dynamic nature of perl
+ # this is easy to confuse, so keep in mind: before this comment no s///, m//, concat or other strong ops on
+ # $amount. after this comment no +,-,*,/,abs. it will only introduce subtle bugs.
+
+ $amount =~ s/0*$// unless defined $places && $places == 0; # cull trailing 0s
+
+ my @d = reverse $numberformat =~ /(\D)/g; # get delim chars
+ my @p = split(/\./, $amount); # split amount at decimal point
+
+ $p[0] =~ s/\B(?=(...)*$)/$d[1]/g if $d[1]; # add 1,000 delimiters
+ $amount = $p[0];
+ if ($places || $p[1]) {
+ $amount .= $d[0]
+ . ( $p[1] || '' )
+ . (0 x max(abs($places || 0) - length ($p[1]||''), 0)); # pad the fraction
+ }
+
+ $amount = do {
+ ($dash =~ /-/) ? ($neg ? "($amount)" : "$amount" ) :
+ ($dash =~ /DRCR/) ? ($neg ? "$amount " . $main::locale->text('DR') : "$amount " . $main::locale->text('CR') ) :
+ ($neg ? "-$amount" : "$amount" ) ;
+ };
+
+ $amount;
+}
+
+sub _round_number {
+ my ($amount, $places, $adjust) = @_;
+
+ return 0 if !defined $amount;
+
+ $places //= 0;
+
+ if ($adjust) {
+ no warnings 'once';
+ my $precision = $::instance_conf->get_precision || 0.01;
+ return _round_number( _round_number($amount / $precision, 0) * $precision, $places);
+ }
+
+ # We use Perl's knowledge of string representation for
+ # rounding. First, convert the floating point number to a string
+ # with a high number of places. Then split the string on the decimal
+ # sign and use integer calculation for rounding the decimal places
+ # part. If an overflow occurs then apply that overflow to the part
+ # before the decimal sign as well using integer arithmetic again.
+
+ my $int_amount = int(abs $amount);
+ my $str_places = max(min(10, 16 - length("$int_amount") - $places), $places);
+ my $amount_str = sprintf '%.*f', $places + $str_places, abs($amount);
+
+ return $amount unless $amount_str =~ m{^(\d+)\.(\d+)$};
+
+ my ($pre, $post) = ($1, $2);
+ my $decimals = '1' . substr($post, 0, $places);
+
+ my $propagation_limit = $Config{i32size} == 4 ? 7 : 18;
+ my $add_for_rounding = substr($post, $places, 1) >= 5 ? 1 : 0;
+
+ if ($places > $propagation_limit) {
+ $decimals = Math::BigInt->new($decimals)->badd($add_for_rounding);
+ $pre = Math::BigInt->new($decimals)->badd(1) if substr($decimals, 0, 1) eq '2';
+
+ } else {
+ $decimals += $add_for_rounding;
+ $pre += 1 if substr($decimals, 0, 1) eq '2';
+ }
+
+ $amount = ("${pre}." . substr($decimals, 1)) * ($amount <=> 0);
+
+ return $amount;
+}
+
+sub _parse_number {
+ my ($amount, %params) = @_;
+
+ return 0 if !defined $amount || $amount eq '';
+
+ my $numberformat = $params{numberformat} // $::myconfig{numberformat};
+
+ if ( ($numberformat eq '1.000,00')
+ || ($numberformat eq '1000,00')) {
+ $amount =~ s/\.//g;
+ $amount =~ s/,/\./g;
+ }
+
+ if ($numberformat eq "1'000.00") {
+ $amount =~ s/\'//g;
+ }
+
+ $amount =~ s/,//g;
+
+ # Make sure no code wich is not a math expression ends up in eval().
+ return 0 unless $amount =~ /^ [\s \d \( \) \- \+ \* \/ \. ]* $/x;
+
+ # Prevent numbers from being parsed as octals;
+ $amount =~ s{ (?<! [\d.] ) 0+ (?= [1-9] ) }{}gx;
+
+ return scalar(eval($amount)) * 1 ;
+}
+
+sub _format_total { _format_number($_[0], 2, @_[1..$#_]) }
+sub _round_total { _round_number($_[0], 2, @_[1..$#_]) }
+
+1;
+
+__END__
+
+=encoding utf-8
+
+=head1 NAME
+
+SL::Helper::Number - number formating functions formerly sitting in SL::Form
+
+=head1 SYNOPSIS
+
+ use SL::Helper::Number qw(all);
+
+ my $str = _format_number($val, 2); # round to 2
+ my $str = _format_number($val, 2, %::myconfig); # also works, is implied
+ my $str = _format_number($val, 2, numberformat => '1.000,00'); # with custom numberformat
+ my $total = _format_total($val); # round to 2
+ my $total = _format_total($val, numberformat => '1.000,00');
+
+ my $val = _parse_number($str); # parse with the current numberformat
+ my $val = _parse_number($str, numberformat => '1.000,00'); # parse with the current numberformat
+
+ my $str = _round_number($val, 2);
+ my $total = _round_total($val); # rounded to 2
+
+=head1 DESCRIPTION
+
+This package contains all the number parsing/formating functions that were
+previously in SL::Form.
+
+Instead of invoking them as methods on C<$::form> these are pure functions.
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item * C<_format_number VALUE PLACES PARAMS>
+
+The old C<SL::Form::format_amount> with a different signature.
+
+The value is expected to be a numeric value, but undef and empty string will be
+vivified to 0 for convinience. Bigints are supported.
+
+For the semantics of places, see L</PLACES>.
+
+If C<params> contains a dash parameter, it will change the formatting of
+positive/negative numbers. If C<-> is given for dash, negative numbers will
+instead be formatted with prentheses. If C<DRCR> is given, the numbers will be
+formatted absolute, but suffixed with the localized versions of C<DR> and
+C<CR>.
+
+=item * _format_total
+
+A curried version used for formatting ledger entries. C<myconfig> is set from the
+current user, C<places> is set to 2. C<dash> is left empty.
+
+=item * _parse_number VALUE PARAMS
+
+Parses expressions into numbers. C<PARAMS> may contain C<numberformat> just
+like with C<L/_format_amount>.
+
+Also implements basic arithmetic interpretation, so that C<2 * 1400> is
+interpreted as 2800.
+
+=item * _round_number VALUE PLACES
+
+Rounds a number. Due to the way Perl handles floating point we take a lot of
+precautions that rounding ends up being close to where we want. Usually the
+internal floats have more than enough precision to not have any floating point
+issues, but the cumulative error can interfere with proper formatting later.
+
+For places, see L</PLACES>
+
+=item * _round_total
+
+A curried version used for rounding ledger entries. C<places> is set to 2.
+
+=back
+
+=head1 PLACES
+
+Places can be:
+
+=over 4
+
+=item * not present
+
+In that case a representation is chosen that looks sufficiently human. For
+example C<1/10> equals C<.1000000000000000555> but will be displayed as the
+localized version of 0.1.
+
+=item * 0
+
+The number will be rounded to the nearest integer (towards 0).
+
+=item * a positive integer
+
+The number will be rounded to this many places. Formatting functions will then
+make sure to pad the output to this many places.
+
+=item * a negative inteher
+
+The number will not be rounded, but padded to at least this many places.
+
+=back
+
+=head1 ERROR REPORTING
+
+All of these do not thow exceptions and will simply return undef should
+something unforeseen happen.
+
+=head1 BUGS AND CAVEATS
+
+Beware that the old C<amount> is now called plain C<number>. C<amount> is
+deliberately unused in the new version for that reason.
+
+=head1 AUTHOR
+
+Sven Schöling E<lt>s.schoeling@linet-services.deE<gt>
+
+=cut
--- /dev/null
+use Test::More tests => 173;
+
+use lib 't';
+
+use SL::Helper::Number qw(:ALL);
+
+use_ok 'Support::TestSetup';
+
+Support::TestSetup::login();
+
+# format
+
+sub test_format {
+ my ($expected, $amount, $places, $numberformat, $dash, $comment) = @_;
+
+ my $other_numberformat = $numberformat eq '1.000,00' ? '1,000.00' : '1.000,00';
+
+ is (_format_number($amount, $places, numberformat => $numberformat, dash => $dash), $expected, "$comment - explicit");
+
+ {
+ local $::myconfig{numberformat} = $other_numberformat;
+ is (_format_number($amount, $places, numberformat => $numberformat, dash => $dash), $expected, "$comment - explicit with different numberformat");
+ }
+ {
+ local $::myconfig{numberformat} = $numberformat;
+ is (_format_number($amount, $places, dash => $dash), $expected, "$comment - implicit numberformat");
+ }
+
+ # test _format_total
+ if (($places // 0) == 2) {
+ is (_format_total($amount, numberformat => $numberformat, dash => $dash), $expected, "$comment - explicit");
+
+ {
+ local $::myconfig{numberformat} = $other_numberformat;
+ is (_format_total($amount, numberformat => $numberformat, dash => $dash), $expected, "$comment - explicit with different numberformat");
+ }
+ {
+ local $::myconfig{numberformat} = $numberformat;
+ is (_format_total($amount, dash => $dash), $expected, "$comment - implicit numberformat");
+ }
+ }
+}
+
+
+test_format('10,00', '1e1', 2, '1.000,00', undef, 'format 1e1 (numberformat: 1.000,00)');
+test_format('1.000,00', 1000, 2, '1.000,00', undef, 'format 1000 (numberformat: 1.000,00)');
+test_format('1.000,12', 1000.1234, 2, '1.000,00', undef, 'format 1000.1234 (numberformat: 1.000,00)');
+test_format('1.000.000.000,12', 1000000000.1234, 2, '1.000,00', undef, 'format 1000000000.1234 (numberformat: 1.000,00)');
+test_format('-1.000.000.000,12', -1000000000.1234, 2, '1.000,00', undef, 'format -1000000000.1234 (numberformat: 1.000,00)');
+
+test_format('10.00', '1e1', 2, '1,000.00', undef, 'format 1e1 (numberformat: 1,000.00)');
+test_format('1,000.00', 1000, 2, '1,000.00', undef, 'format 1000 (numberformat: 1,000.00)');
+test_format('1,000.12', 1000.1234, 2, '1,000.00', undef, 'format 1000.1234 (numberformat: 1,000.00)');
+test_format('1,000,000,000.12', 1000000000.1234, 2, '1,000.00', undef, 'format 1000000000.1234 (numberformat: 1,000.00)');
+test_format('-1,000,000,000.12', -1000000000.1234, 2, '1,000.00', undef, 'format -1000000000.1234 (numberformat: 1,000.00)');
+
+# negative places
+
+test_format('1.00045', 1.00045, -2, '1,000.00', undef, 'negative places');
+test_format('1.00045', 1.00045, -5, '1,000.00', undef, 'negative places 2');
+test_format('1.00', 1, -2, '1,000.00', undef, 'negative places 3');
+
+# bugs amd edge cases
+test_format('0,00005', 0.00005, undef, '1.000,00', undef, 'messing with small numbers and no precision');
+test_format('0', undef, undef, '1.000,00', undef, 'undef');
+test_format('0', '', undef, '1.000,00', undef, 'empty string');
+test_format('0,00', undef, 2, '1.000,00', undef, 'undef with precision');
+test_format('0,00', '', 2, '1.000,00', undef, 'empty string with prcesion');
+
+test_format('1', 0.545, 0, '1.000,00', undef, 'rounding up with precision 0');
+test_format('-1', -0.545, 0, '1.000,00', undef, 'neg rounding up with precision 0');
+
+test_format('1', 1.00, undef, '1.000,00', undef, 'autotrim to 0 places');
+
+test_format('10', 10, undef, '1.000,00', undef, 'autotrim does not harm integers');
+test_format('10,00', 10, 2, '1.000,00', undef, 'autotrim does not harm integers 2');
+test_format('10,00', 10, -2, '1.000,00', undef, 'autotrim does not harm integers 3');
+test_format('10', 10, 0, '1.000,00', undef, 'autotrim does not harm integers 4');
+
+test_format('0', 0, 0, '1.000,00', undef, 'trivial zero');
+test_format('0,00', -0.002, 2, '1.000,00', undef, 'negative zero');
+test_format('-0,002', -0.002, 3, '1.000,00', undef, 'negative zero');
+
+# dash
+
+test_format('(350,00)', -350, 2, '1.000,00', '-', 'dash -');
+
+# parse
+
+sub test_parse {
+ my ($expected, $amount, $numberformat, $comment) = @_;
+
+ my $other_numberformat = $numberformat eq '1.000,00' ? '1,000.00' : '1.000,00';
+
+ is (_parse_number($amount, numberformat => $numberformat), $expected, "$comment - explicit");
+
+ {
+ local $::myconfig{numberformat} = $other_numberformat;
+ is (_parse_number($amount, numberformat => $numberformat), $expected, "$comment - explicit with different numberformat");
+ }
+ {
+ local $::myconfig{numberformat} = $numberformat;
+ is (_parse_number($amount), $expected, "$comment - implicit numberformat");
+ }
+}
+
+
+test_parse(12345, '12345', '1.000,00', '12345 (numberformat: 1.000,00)');
+test_parse(1234.5, '1.234,5', '1.000,00', '1.234,5 (numberformat: 1.000,00)');
+test_parse(9871234.5, '9.871.234,5', '1.000,00', '9.871.234,5 (numberformat: 1.000,00)');
+test_parse(1234.5, '1234,5', '1.000,00', '1234,5 (numberformat: 1.000,00)');
+test_parse(12345, '012345', '1.000,00', '012345 (numberformat: 1.000,00)');
+test_parse(1234.5, '01.234,5', '1.000,00', '01.234,5 (numberformat: 1.000,00)');
+test_parse(1234.5, '01234,5', '1.000,00', '01234,5 (numberformat: 1.000,00)');
+test_parse(9871234.5, '09.871.234,5', '1.000,00', '09.871.234,5 (numberformat: 1.000,00)');
+
+# round
+
+is(_round_number('3.231',2),'3.23');
+is(_round_number('3.234',2),'3.23');
+is(_round_number('3.235',2),'3.24');
+is(_round_number('5.786',2),'5.79');
+is(_round_number('2.342',2),'2.34');
+is(_round_number('1.2345',2),'1.23');
+is(_round_number('8.2345',2),'8.23');
+is(_round_number('8.2350',2),'8.24');
+
+
+is(_round_total('3.231'),'3.23');
+is(_round_total('3.234'),'3.23');
+is(_round_total('3.235'),'3.24');
+is(_round_total('5.786'),'5.79');
+is(_round_total('2.342'),'2.34');
+is(_round_total('1.2345'),'1.23');
+is(_round_total('8.2345'),'8.23');
+is(_round_total('8.2350'),'8.24');
projects / mfinanz.git / commitdiff