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