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