File Coverage

blib/lib/Format/Util/Numbers.pm
Criterion Covered Total %
statement 87 87 100.0
branch 34 34 100.0
condition 40 48 83.3
subroutine 19 19 100.0
pod 8 8 100.0
total 188 196 95.9


line stmt bran cond sub pod time code
1             package Format::Util::Numbers;
2              
3 1     1   77853 use 5.006;
  1         12  
4 1     1   7 use strict;
  1         2  
  1         38  
5 1     1   6 use warnings FATAL => 'all';
  1         2  
  1         41  
6              
7 1     1   5 use base 'Exporter';
  1         1  
  1         138  
8             our @EXPORT_OK = qw/commas to_monetary_number_format roundnear roundcommon financialrounding formatnumber get_min_unit/;
9              
10 1     1   7 use Carp qw(cluck);
  1         2  
  1         67  
11 1     1   7 use Scalar::Util qw(looks_like_number);
  1         2  
  1         55  
12 1     1   503 use POSIX qw(ceil);
  1         6716  
  1         6  
13 1     1   1868 use YAML::XS;
  1         2901  
  1         55  
14 1     1   502 use File::ShareDir;
  1         30506  
  1         53  
15 1     1   1107 use Math::BigFloat lib => 'Calc';
  1         57020  
  1         6  
16              
17             =head1 NAME
18              
19             Format::Util::Numbers - Miscellaneous routines to do with manipulating number format!
20              
21             =cut
22              
23             our $VERSION = '0.16'; ## VERSION
24              
25             =head1 SYNOPSIS
26              
27             use Format::Util::Numbers qw( commas to_monetary_number_format roundnear formatnumber financialrounding);
28             ...
29              
30             =head1 EXPORT
31              
32             =head2 roundnear
33              
34             Round a number near the precision of the supplied one.
35              
36             roundnear( 0.01, 12345.678) => 12345.68
37              
38             =cut
39              
40             {
41             #cf. Math::Round
42             my $halfdec = do {
43             my $halfhex = unpack('H*', pack('d', 0.5));
44             if (substr($halfhex, 0, 2) ne '00' && substr($halfhex, -2) eq '00') {
45             substr($halfhex, -4) = '1000';
46             } else {
47             substr($halfhex, 0, 4) = '0010';
48             }
49             unpack('d', pack('H*', $halfhex));
50             };
51              
52             sub roundnear {
53 206     206 1 90893 my ($targ, $input) = @_;
54              
55 206 100       509 return $input if (not defined $input);
56              
57 205         330 my $rounded = $input;
58             # rounding to 0, doesnt really make sense, but viewing it as a limit process
59             # it means do not round at all
60 205 100       509 if ($targ != 0) {
61 204 100       808 $rounded =
62             ($input >= 0)
63             ? $targ * int(($input + $halfdec * $targ) / $targ)
64             : $targ * ceil(($input - $halfdec * $targ) / $targ);
65             }
66             # Avoid any possible -0 rounding situations.
67 205         1968 return 1 * $rounded;
68             }
69             }
70              
71             # format of precsion should be
72             # TYPE:
73             # CURRENCY: PRECISION
74             my $precisions = YAML::XS::LoadFile($ENV{FORMAT_UTIL_PRECISION} // File::ShareDir::dist_file('Format-Util', 'precision.yml'));
75             my $floating_point_regex = qr/^[-+]?[0-9]*\.?[0-9]+([eE][-+]?[0-9]+)?$/;
76              
77             =head2 commas
78              
79             Produce a more human readbale number with a provided number of decimal points
80              
81             commas(12345.679, 1) => 12,345.7
82              
83             =cut
84              
85             sub commas {
86 117     117 1 2969 my ($x, $decimal_point) = @_;
87              
88 117         189 my $output = $x;
89 117 100       430 return $output if not looks_like_number($x);
90              
91 116 100       312 if ($x < 0) {
92 2         9 $output = '-' . commas(-1 * $x, $decimal_point);
93             } else {
94             # Split non-decimal and decimal value
95 114         191 $x = $x * 1;
96 114         1024 $x =~ /^(\d*)(\.?\d*)/;
97 114         294 $x = $1;
98 114         191 my $last_num = $2;
99              
100 114         173 my @segments;
101 114         551 while ($x =~ s/(\d{3})$//) {
102 115         441 unshift @segments, $1;
103             }
104 114 100       237 if ($x) {
    100          
105 105         193 unshift @segments, $x;
106             } elsif (not scalar @segments) {
107 1         4 unshift @segments, 0;
108             }
109 114 100       218 if ($decimal_point) {
    100          
110 108         268 my $format = '%.' . int($decimal_point) . 'f';
111 108         892 $last_num = sprintf $format, $last_num;
112 108         435 $last_num =~ s/^0//;
113             } elsif (defined $decimal_point) {
114 5 100 100     24 $segments[-1]++ if $last_num && $last_num > 0.5;
115 5         8 $last_num = '';
116             }
117 114         397 $output = (join ',', @segments) . $last_num;
118             }
119              
120 116         746 return $output;
121             }
122              
123             =head2 to_monetary_number_format
124              
125             Produce a nice human readable number which looks like a currency
126              
127             to_monetary_number_format(123456789) => 123,456,789.00
128              
129             =cut
130              
131             sub to_monetary_number_format {
132             # This routine is adjusted for our system, but the basic algorithm
133             # is from Perl Cookbook, 1st Ed, Recipe 2.17
134 111     111 1 2813 my ($text, $remove_decimal_for_ints) = @_;
135              
136 111   100     262 $text //= 0;
137              
138 111 100       385 if (looks_like_number($text)) {
139 110         888 $text = reverse sprintf "%.2f", $text;
140 110         1057 $text =~ s/(\d{3})/$1,/g;
141 110         461 $text =~ s/^,|,$//g;
142 110         220 $text =~ s/,-$/-/g;
143 110         250 $text = scalar reverse $text;
144 110 100       236 $text =~ s/\.00$// if ($remove_decimal_for_ints);
145             }
146              
147 111         746 return $text;
148             }
149              
150             =head2 formatnumber
151              
152             This sub is used to format number as per precision defined
153             per currency.
154              
155             Use this sub only for formatting not for rounding, i.e
156             use this in modules which are used for display purpose
157             only i.e client facing.
158              
159             DON'T USE THIS FOR CALCULATION, COMPARISON OF NUMBERS
160             DON'T USE THIS FOR QUANTITATIVE ANALYSIS
161              
162             This sub accepts type i.e whether its price or amount
163             - price e.g. ask price, bid price
164             - amount e.g. balance, deposit/withdraw amount
165              
166             and takes currency to calculate precision defined per
167             currency.
168              
169             this subs takes precision defined per currency in config file passed by
170             ENV{FORMAT_UTIL_PRECISION}, else it defaults to precision.yml
171              
172             Returns string
173              
174             formatnumber('price', 'USD', 10) => 10.00
175              
176             =cut
177              
178             sub formatnumber {
179 38     38 1 2600 my ($type, $currency, $val) = @_;
180              
181             # return val if any one of value, currency or type is invalid
182             return $val
183             if ((
184             not defined $val
185             or $val !~ $floating_point_regex
186             )
187             or not defined $precisions->{$type // 'unknown-type'}
188 38 100 100     637 or not defined $precisions->{$type}->{$currency // 'unknown-type'});
      50        
      100        
      50        
      100        
189              
190 33         317 return sprintf('%0.0' . $precisions->{$type}->{$currency} . 'f', $val);
191             }
192              
193             =head2 financialrounding
194              
195             This sub is used to round number as per precision defined
196             per currency.
197              
198             Use this sub only for rounding numbers thats are related
199             to currency like price, amount, balance etc
200              
201             USE THIS WHEN YOU WANT TO COMPARE NUMBERS RELATED TO CURRENCY
202             USE THIS FOR QUANTITATIVE ANALYSIS FOR NUMBER RELATED TO CURRENCY
203              
204             This sub accepts type i.e whether its price or amount
205             - price e.g. ask price, bid price
206             - amount e.g. balance, deposit/withdraw amount
207              
208             and takes currency to calculate precision defined per
209             currency.
210              
211             this subs takes precision defined per currency in config file passed by
212             ENV{FORMAT_UTIL_PRECISION}, else it defaults to precision.yml
213              
214             Returns string
215              
216             financialrounding('amount', 'USD', 10.345) => '10.35'
217              
218             =cut
219              
220             sub financialrounding {
221 26     26 1 14486 my ($type, $currency, $val) = @_;
222              
223             # return val if any one of value, currency or type is invalid
224             return $val
225             if ((
226             not defined $val
227             or $val !~ $floating_point_regex
228             )
229             or not defined $precisions->{$type // 'unknown-type'}
230 26 100 100     876 or not defined $precisions->{$type}->{$currency // 'unknown-type'});
      50        
      100        
      50        
      100        
231              
232 21         80 return _round_to_precison($precisions->{$type}->{$currency}, $val);
233             }
234              
235             =head2 roundcommon
236              
237             This sub rounds number as per precision passed, this sub
238             should be used for numbers not related to currencies like
239             probabilities, percentages etc
240              
241             This sub use round away from zero technique, same as
242             financial rounding, the only difference is it acccepts
243             precision as shown below and has no currency precision
244              
245             Acceptable precision values format example:
246              
247             0
248             1
249             1e-4
250             0.0001
251              
252             This sub only supports rounding to one tenths, hundredths,
253             thousandths and so on. It does not support rounding to two,
254             three tenths, hundredths or so, use roundnear for that.
255              
256             This sub is created as replacement for roundnear as roundnear
257             for small numbers it does round away from zero,
258             for numbers with more significant digits it's sort-of random
259              
260             Returns string
261              
262             roundcommon(0.01, 10.234) => '10.23'
263              
264             =cut
265              
266             sub roundcommon {
267 13     13 1 6962 my ($precision, $val) = @_;
268              
269 13 100 66     310 return $val
      66        
      100        
      100        
270             if ((
271             not defined $val
272             or $val !~ $floating_point_regex
273             )
274             or (not defined $precision or $precision !~ /^(?:1(?:[eE][-]?[0-9]+)?|0(?:\.0*1)?)$/ or $precision == 0));
275              
276             # get the number of decimal places needed by BigFloat
277 8         34 $precision = log(1 / $precision) / log(10);
278              
279 8         21 return _round_to_precison($precision, $val);
280             }
281              
282             =head2 get_precision_config
283              
284             This is used get complete currency precision config.
285              
286             =cut
287              
288             sub get_precision_config {
289 1     1 1 2249 return $precisions;
290             }
291              
292             =head2 get_min_unit
293              
294             Given a currency, this subroutine obtains the smallest possible unit of a currency using the currency's pip size.
295              
296             For example, if the currency requested is USD, this function will return 0.01.
297              
298             Everything returned in this function is considered a price.
299              
300             =cut
301              
302             sub get_min_unit {
303              
304 10     10 1 3641 my $currency = shift;
305              
306             die "Currency $currency and/or its precision is not defined."
307             if ((not defined $currency)
308 10 100 50     82 or not defined $precisions->{price}->{$currency // 'unknown-type'});
      66        
309              
310             # For cases where the precision is 0, we return 1 as the smallest denomination
311 9 100       28 return 1 if $precisions->{price}->{$currency} == 0;
312              
313 8         30 return formatnumber('price', $currency, 1 / 10**($precisions->{price}->{$currency}));
314             }
315              
316             # common sub used by roundcommon and financialrounding
317             sub _round_to_precison {
318 29     29   67 my ($precision, $val) = @_;
319              
320 29         112 my $x = Math::BigFloat->bzero();
321 29         979 $x->badd($val)->bfround('-' . $precision, 'common');
322              
323 29         17158 return $x->bstr();
324             }
325              
326             =head1 AUTHOR
327              
328             binary.com, C<< >>
329              
330             =head1 BUGS
331              
332             Please report any bugs or feature requests to C, or through
333             the web interface at L. I will be notified, and then you'll
334             automatically be notified of progress on your bug as I make changes.
335              
336             =head1 SUPPORT
337              
338             You can find documentation for this module with the perldoc command.
339              
340             perldoc Format::Util::Numbers
341              
342             You can also look for information at:
343              
344             =over 4
345              
346             =item * RT: CPAN's request tracker (report bugs here)
347              
348             L
349              
350             =item * AnnoCPAN: Annotated CPAN documentation
351              
352             L
353              
354             =item * CPAN Ratings
355              
356             L
357              
358             =item * Search CPAN
359              
360             L
361              
362             =back
363              
364             =head1 ACKNOWLEDGEMENTS
365              
366             =head1 LICENSE AND COPYRIGHT
367              
368             Copyright 2014 binary.com.
369              
370             This program is free software; you can redistribute it and/or modify it
371             under the terms of the the Artistic License (2.0). You may obtain a
372             copy of the full license at:
373              
374             L
375              
376             Any use, modification, and distribution of the Standard or Modified
377             Versions is governed by this Artistic License. By using, modifying or
378             distributing the Package, you accept this license. Do not use, modify,
379             or distribute the Package, if you do not accept this license.
380              
381             If your Modified Version has been derived from a Modified Version made
382             by someone other than you, you are nevertheless required to ensure that
383             your Modified Version complies with the requirements of this license.
384              
385             This license does not grant you the right to use any trademark, service
386             mark, tradename, or logo of the Copyright Holder.
387              
388             This license includes the non-exclusive, worldwide, free-of-charge
389             patent license to make, have made, use, offer to sell, sell, import and
390             otherwise transfer the Package with respect to any patent claims
391             licensable by the Copyright Holder that are necessarily infringed by the
392             Package. If you institute patent litigation (including a cross-claim or
393             counterclaim) against any party alleging that the Package constitutes
394             direct or contributory patent infringement, then this Artistic License
395             to you shall terminate on the date that such litigation is filed.
396              
397             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
398             AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
399             THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
400             PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
401             YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
402             CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
403             CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
404             EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
405              
406             =cut
407              
408             1; # End of Format::Util::Numbers