File Coverage

blib/lib/Number/Format/Metric.pm
Criterion Covered Total %
statement 42 57 73.6
branch 28 62 45.1
condition 18 40 45.0
subroutine 7 7 100.0
pod 1 1 100.0
total 96 167 57.4


line stmt bran cond sub pod time code
1             package Number::Format::Metric;
2              
3 2     2   549193 use 5.010001;
  2         8  
4 2     2   1314 use locale;
  2         2036  
  2         23  
5 2     2   110 use strict;
  2         5  
  2         52  
6 2     2   693 use utf8;
  2         357  
  2         14  
7 2     2   81 use warnings;
  2         4  
  2         103  
8              
9 2     2   11 use Exporter qw(import);
  2         5  
  2         1346  
10              
11             our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
12             our $DATE = '2025-09-24'; # DATE
13             our $DIST = 'Number-Format-Metric'; # DIST
14             our $VERSION = '0.604'; # VERSION
15              
16             our @EXPORT_OK = qw(
17             format_metric
18             );
19              
20             sub format_metric {
21 11     11 1 487625 my ($num, $opts) = @_;
22 11   50     69 $opts //= {};
23 11   100     46 $opts->{base} //= 2;
24              
25 11   100     53 my $im = $opts->{i_mark} // 1;
26 11         22 my $base0 = $opts->{base};
27 11 100       32 my $base = $base0 == 2 ? 1024 : 1000;
28 11         22 my $uck = $opts->{uppercase_k};
29 11         20 my $latin = $opts->{latin_only};
30 11   100     38 my $addp = $opts->{additional_prefix} // '';
31              
32 11         48 my $rank;
33             my $prefix;
34 11 50       31 if ($num == 0) {
35 0         0 $rank = 0;
36 0         0 $prefix = "";
37             } else {
38 11         53 $rank = int(log(abs($num))/log($base));
39 11 100 100     115 if ($rank == 0 && abs($num) >= 1) { $prefix = "" }
  2 100       7  
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
40 3 100 66     11 elsif ($rank == 1) { my $k = $uck ? "K" : "k"; $prefix = $im && $base0==10 ? "${k}i" : $k } # kilo
  3 100       34  
41 0 0 0     0 elsif ($rank == 2) { $prefix = $im && $base0==10 ? "Mi" : "M" } # mega
42 1 50 33     38 elsif ($rank == 3) { $prefix = $im && $base0==10 ? "Gi" : "G" } # giga
43 0 0 0     0 elsif ($rank == 4) { $prefix = $im && $base0==10 ? "Ti" : "T" } # tera
44 0 0 0     0 elsif ($rank == 5) { $prefix = $im && $base0==10 ? "Pi" : "P" } # peta
45 0 0 0     0 elsif ($rank >= 8) { $prefix = $im && $base0==10 ? "Yi" : "Y" } # yotta
46 0 0 0     0 elsif ($rank == 7) { $prefix = $im && $base0==10 ? "Zi" : "Z" } # zetta
47 0 0 0     0 elsif ($rank == 6) { $prefix = $im && $base0==10 ? "Ei" : "E" } # exa
48 2         6 elsif ($rank == 0) { $prefix = "m" } # milli
49 3 100       13 elsif ($rank == -1) { $prefix = $latin ? "mc" : "μ" } # micro
50 0         0 elsif ($rank == -2) { $prefix = "n" } # nano
51 0         0 elsif ($rank == -3) { $prefix = "p" } # pico
52 0         0 elsif ($rank == -4) { $prefix = "f" } # femto
53 0         0 elsif ($rank == -5) { $prefix = "a" } # atto
54 0         0 elsif ($rank == -6) { $prefix = "z" } # zepto
55 0         0 elsif ($rank <= -7) { $prefix = "y" } # yocto
56             }
57 11         27 $prefix .= $addp;
58              
59 11   100     41 my $prec = $opts->{precision} // 1;
60 11 100 100     91 $num = $num / $base**($rank <= 0 && abs($num) < 1 ? $rank-1 : $rank);
61 11 50       32 if ($opts->{return_array}) {
62 0         0 return [$num, $prefix];
63             } else {
64 11         128 my $snum = sprintf("%.${prec}f", $num);
65 11         110 return $snum . $prefix;
66             }
67             }
68              
69             1;
70             # ABSTRACT: Format number with metric prefix, with some options
71              
72             __END__