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