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