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