Commit | Line | Data |
---|---|---|
86530b38 AT |
1 | package Number::Format; |
2 | ||
3 | require 5.003; | |
4 | ||
5 | =head1 NAME | |
6 | ||
7 | Number::Format - Perl extension for formatting numbers | |
8 | ||
9 | =head1 SYNOPSIS | |
10 | ||
11 | use Number::Format; | |
12 | my $x = new Number::Format %args; | |
13 | $formatted = $x->round($number, $precision); | |
14 | $formatted = $x->format_number($number, $precision, $trailing_zeroes); | |
15 | $formatted = $x->format_negative($number, $picture); | |
16 | $formatted = $x->format_picture($number, $picture); | |
17 | $formatted = $x->format_price($number, $precision); | |
18 | $formatted = $x->format_bytes($number, $precision); | |
19 | $number = $x->unformat_number($formatted); | |
20 | ||
21 | use Number::Format qw(:subs); | |
22 | $formatted = round($number, $precision); | |
23 | $formatted = format_number($number, $precision, $trailing_zeroes); | |
24 | $formatted = format_negative($number, $picture); | |
25 | $formatted = format_picture($number, $picture); | |
26 | $formatted = format_price($number, $precision); | |
27 | $formatted = format_bytes($number, $precision); | |
28 | $number = unformat_number($formatted); | |
29 | ||
30 | =head1 REQUIRES | |
31 | ||
32 | Perl, version 5.003 or higher. | |
33 | ||
34 | POSIX.pm will be used if present to determine locale settings. | |
35 | ||
36 | Carp.pm is used for some error reporting. | |
37 | ||
38 | =head1 DESCRIPTION | |
39 | ||
40 | These functions provide an easy means of formatting numbers in a | |
41 | manner suitable for displaying to the user. | |
42 | ||
43 | There are two ways to use this package. One is to declare an object | |
44 | of type Number::Format, which you can think of as a formatting engine. | |
45 | The various functions defined here are provided as object methods. | |
46 | The constructor C<new()> can be used to set the parameters of the | |
47 | formatting engine. Valid parameters are: | |
48 | ||
49 | THOUSANDS_SEP - character inserted between groups of 3 digits | |
50 | DECIMAL_POINT - character separating integer and fractional parts | |
51 | MON_THOUSANDS_SEP - like THOUSANDS_SEP, but used for format_price | |
52 | MON_DECIMAL_POINT - like DECIMAL_POINT, but used for format_price | |
53 | INT_CURR_SYMBOL - character(s) denoting currency (see format_price()) | |
54 | DECIMAL_DIGITS - number of digits to the right of dec point (def 2) | |
55 | DECIMAL_FILL - boolean; whether to add zeroes to fill out decimal | |
56 | NEG_FORMAT - format to display negative numbers (def ``-x'') | |
57 | KILO_SUFFIX - suffix to add when format_bytes formats kilobytes | |
58 | MEGA_SUFFIX - " " " " " " megabytes | |
59 | GIGA_SUFFIX - " " " " " " gigabytes | |
60 | ||
61 | They may be specified in upper or lower case, with or without a | |
62 | leading hyphen ( - ). | |
63 | ||
64 | The defaults for C<THOUSANDS_SEP>, C<DECIMAL_POINT>, | |
65 | C<MON_THOUSANDS_SEP>, C<MON_DECIMAL_POINT>, and C<INT_CURR_SYMBOL> | |
66 | come from the POSIX locale information (see L<perllocale>), if | |
67 | available. If your POSIX locale does not provide C<MON_THOUSANDS_SEP> | |
68 | and/or C<MON_DECIMAL_POINT> fields, then the C<THOUSANDS_SEP> and/or | |
69 | C<DECIMAL_POINT> values are used for those parameters. Some systems | |
70 | (e.g. Win32 ports of Perl) do not include POSIX support. In those | |
71 | systems, the POSIX system is bypassed. | |
72 | ||
73 | If any of the above parameters are not specified when you invoke | |
74 | C<new()>, then the values are taken from package global variables of | |
75 | the same name (e.g. C<$DECIMAL_POINT> is the default for the | |
76 | C<DECIMAL_POINT> parameter). If you use the C<:vars> keyword on your | |
77 | C<use Number::Format> line (see non-object-oriented example below) you | |
78 | will import those variables into your namesapce and can assign values | |
79 | as if they were your own local variables. The default values for all | |
80 | the parameters are: | |
81 | ||
82 | THOUSANDS_SEP = ',' | |
83 | DECIMAL_POINT = '.' | |
84 | MON_THOUSANDS_SEP = ',' | |
85 | MON_DECIMAL_POINT = '.' | |
86 | INT_CURR_SYMBOL = 'USD' | |
87 | DECIMAL_DIGITS = 2 | |
88 | DECIMAL_FILL = 0 | |
89 | NEG_FORMAT = '-x' | |
90 | KILO_SUFFIX = 'K' | |
91 | MEGA_SUFFIX = 'M' | |
92 | GIGA_SUFFIX = 'G' | |
93 | ||
94 | Note however that when you first call one of the functions in this | |
95 | module I<without> using the object-oriented interface, further setting | |
96 | of those global variables will have no effect on non-OO calls. It is | |
97 | recommended that you use the object-oriented interface instead for | |
98 | fewer headaches and a cleaner design. | |
99 | ||
100 | The C<DECIMAL_FILL> and C<DECIMAL_DIGITS> values are not set by the | |
101 | Locale system, but are definable by the user. They affect the output | |
102 | of C<format_number()>. Setting C<DECIMAL_DIGITS> is like giving that | |
103 | value as the C<$precision> argument to that function. Setting | |
104 | C<DECIMAL_FILL> to a true value causes C<format_number()> to append | |
105 | zeroes to the right of the decimal digits until the length is the | |
106 | specified number of digits. | |
107 | ||
108 | C<NEG_FORMAT> is only used by C<format_negative()> and is a string | |
109 | containing the letter 'x', where that letter will be replaced by a | |
110 | positive representation of the number being passed to that function. | |
111 | C<format_number()> and C<format_price()> utilize this feature by | |
112 | calling C<format_negative()> if the number was less than 0. | |
113 | ||
114 | C<KILO_SUFFIX>, C<MEGA_SUFFIX>, and C<GIGA_SUFFIX> are used by | |
115 | C<format_bytes()> when the value is over 1024, 1024*1024, or | |
116 | 1024*1024*1024, respectively. The default values are "K", "M", and | |
117 | "G". Note: we can't do TERA because of integer overflows on 32-bit | |
118 | systems. | |
119 | ||
120 | The only restrictions on C<DECIMAL_POINT> and C<THOUSANDS_SEP> are that | |
121 | they must not be digits, must not be identical, and must each be one | |
122 | character. There are no restrictions on C<INT_CURR_SYMBOL>. | |
123 | ||
124 | For example, a German user might include this in their code: | |
125 | ||
126 | use Number::Format; | |
127 | my $de = new Number::Format(-thousands_sep => '.', | |
128 | -decimal_point => ',', | |
129 | -int_curr_symbol => 'DEM'); | |
130 | my $formatted = $de->format_number($number); | |
131 | ||
132 | Or, if you prefer not to use the object oriented interface, you can do | |
133 | this instead: | |
134 | ||
135 | use Number::Format qw(:subs :vars); | |
136 | $THOUSANDS_SEP = '.'; | |
137 | $DECIMAL_POINT = ','; | |
138 | $INT_CURR_SYMBOL = 'DEM'; | |
139 | my $formatted = format_number($number); | |
140 | ||
141 | =head1 EXPORTS | |
142 | ||
143 | Nothing is exported by default. To export the functions or the global | |
144 | variables defined herein, specify the function name(s) on the import | |
145 | list of the C<use Number::Format> statement. To export all functions | |
146 | defined herein, use the special tag C<:subs>. To export the | |
147 | variables, use the special tag C<:vars>; to export both subs and vars | |
148 | you can use the tag C<:all>. | |
149 | ||
150 | =cut | |
151 | ||
152 | ###--------------------------------------------------------------------- | |
153 | ||
154 | use strict; | |
155 | use vars qw($DECIMAL_DIGITS $DECIMAL_FILL $DECIMAL_POINT | |
156 | $DEFAULT_LOCALE $INT_CURR_SYMBOL $KILO_SUFFIX $MEGA_SUFFIX | |
157 | $GIGA_SUFFIX $NEG_FORMAT $POSIX_LOADED $THOUSANDS_SEP | |
158 | $VERSION %EXPORT_TAGS @EXPORT_OK @EXPORT_SUBS @EXPORT_VARS | |
159 | @ISA); | |
160 | use Exporter; | |
161 | use Carp; | |
162 | ||
163 | BEGIN | |
164 | { | |
165 | eval { require POSIX; POSIX->import( qw(locale_h) ) }; | |
166 | if ($@) | |
167 | { | |
168 | # code to provide alternate definitions for POSIX functions | |
169 | *localeconv = sub { $DEFAULT_LOCALE }; # return default | |
170 | *setlocale = sub { }; # do nothing | |
171 | *LC_ALL = sub { }; # do nothing | |
172 | $POSIX_LOADED = 0; | |
173 | } | |
174 | else | |
175 | { | |
176 | $POSIX_LOADED = 1; | |
177 | } | |
178 | } | |
179 | ||
180 | @ISA = qw(Exporter); | |
181 | ||
182 | @EXPORT_SUBS = qw(format_number format_negative format_picture | |
183 | format_price format_bytes round unformat_number); | |
184 | @EXPORT_VARS = qw($DECIMAL_DIGITS $DECIMAL_FILL $DECIMAL_POINT | |
185 | $DEFAULT_LOCALE $INT_CURR_SYMBOL $KILO_SUFFIX | |
186 | $MEGA_SUFFIX $GIGA_SUFFIX $NEG_FORMAT $POSIX_LOADED | |
187 | $THOUSANDS_SEP); | |
188 | @EXPORT_OK = (@EXPORT_SUBS, @EXPORT_VARS); | |
189 | %EXPORT_TAGS = (subs => \@EXPORT_SUBS, | |
190 | vars => \@EXPORT_VARS, | |
191 | all => [ @EXPORT_SUBS, @EXPORT_VARS ]); | |
192 | ||
193 | $VERSION = '1.45'; | |
194 | ||
195 | $DECIMAL_POINT = '.'; | |
196 | $THOUSANDS_SEP = ','; | |
197 | $INT_CURR_SYMBOL = 'USD'; | |
198 | $DECIMAL_DIGITS = 2; | |
199 | $DECIMAL_FILL = 0; | |
200 | $NEG_FORMAT = '-x'; | |
201 | $KILO_SUFFIX = 'K'; | |
202 | $MEGA_SUFFIX = 'M'; | |
203 | $GIGA_SUFFIX = 'G'; | |
204 | ||
205 | $DEFAULT_LOCALE = { mon_thousands_sep => $THOUSANDS_SEP, | |
206 | mon_decimal_point => $DECIMAL_POINT, | |
207 | thousands_sep => $THOUSANDS_SEP, | |
208 | decimal_point => $DECIMAL_POINT, | |
209 | int_curr_symbol => $INT_CURR_SYMBOL, | |
210 | neg_format => $NEG_FORMAT, | |
211 | kilo_suffix => $KILO_SUFFIX, | |
212 | mega_suffix => $MEGA_SUFFIX, | |
213 | giga_suffix => $GIGA_SUFFIX, | |
214 | decimal_digits => $DECIMAL_DIGITS, | |
215 | decimal_fill => $DECIMAL_FILL, | |
216 | }; | |
217 | ||
218 | ###--------------------------------------------------------------------- | |
219 | ||
220 | # INTERNAL FUNCTIONS | |
221 | ||
222 | # These functions (with names beginning with '_' are for internal use | |
223 | # only. There is no guarantee that they will remain the same from one | |
224 | # version to the next! | |
225 | ||
226 | ##---------------------------------------------------------------------- | |
227 | ||
228 | # _get_self creates an instance of Number::Format with the default | |
229 | # values for the configuration parameters, if the first element of | |
230 | # @_ is not already an object. | |
231 | ||
232 | my $DefaultObject; | |
233 | sub _get_self | |
234 | { | |
235 | unless (ref $_[0]) | |
236 | { | |
237 | $DefaultObject ||= new Number::Format(); | |
238 | unshift (@_, $DefaultObject); | |
239 | } | |
240 | @_; | |
241 | } | |
242 | ||
243 | ##---------------------------------------------------------------------- | |
244 | ||
245 | # _check_seps is used to validate that the thousands_sep and | |
246 | # decimal_point variables have acceptable values. For internal use | |
247 | # only. | |
248 | ||
249 | sub _check_seps | |
250 | { | |
251 | my ($self) = @_; | |
252 | croak "Not an object" unless ref $self; | |
253 | croak "Number::Format: {thousands_sep} must be one character\n" | |
254 | if length $self->{thousands_sep} != 1; | |
255 | croak "Number::Format: {thousands_sep} may not be numeric\n" | |
256 | if $self->{thousands_sep} =~ /\d/; | |
257 | croak "Number::Format: {decimal_point} must be one character\n" | |
258 | if length $self->{decimal_point} != 1; | |
259 | croak "Number::Format: {decimal_point} may not be numeric\n" | |
260 | if $self->{decimal_point} =~ /\d/; | |
261 | croak("Number::Format: {thousands_sep} and {decimal_point} ". | |
262 | "may not be equal\n") | |
263 | if $self->{decimal_point} eq $self->{thousands_sep}; | |
264 | } | |
265 | ||
266 | ###--------------------------------------------------------------------- | |
267 | ||
268 | =head1 METHODS | |
269 | ||
270 | =over 4 | |
271 | ||
272 | =cut | |
273 | ||
274 | ##---------------------------------------------------------------------- | |
275 | ||
276 | =item new( %args ) | |
277 | ||
278 | Creates a new Number::Format object. Valid keys for %args are any of | |
279 | the parameters described above. Keys may be in all uppercase or all | |
280 | lowercase, and may optionally be preceded by a hyphen (-) character. | |
281 | Example: | |
282 | ||
283 | my $de = new Number::Format(-thousands_sep => '.', | |
284 | -decimal_point => ',', | |
285 | -int_curr_symbol => 'DEM'); | |
286 | ||
287 | =cut | |
288 | ||
289 | sub new | |
290 | { | |
291 | my $type = shift; | |
292 | my %args = @_; | |
293 | ||
294 | # Fetch defaults from current locale, or failing that, using globals | |
295 | my $me = {}; | |
296 | my $locale = setlocale(LC_ALL); | |
297 | my $locale_values = localeconv(); | |
298 | my $arg; | |
299 | foreach $arg (keys %$locale_values) | |
300 | { | |
301 | $me->{$arg} = $locale_values->{$arg}; | |
302 | } | |
303 | $me->{mon_decimal_point} ||= $DECIMAL_POINT; | |
304 | $me->{mon_thousands_sep} ||= $THOUSANDS_SEP; | |
305 | $me->{int_curr_symbol} ||= $INT_CURR_SYMBOL; | |
306 | $me->{decimal_digits} ||= $DECIMAL_DIGITS; | |
307 | $me->{decimal_fill} ||= $DECIMAL_FILL; | |
308 | $me->{neg_format} ||= $NEG_FORMAT; | |
309 | $me->{kilo_suffix} ||= $KILO_SUFFIX; | |
310 | $me->{mega_suffix} ||= $MEGA_SUFFIX; | |
311 | $me->{giga_suffix} ||= $GIGA_SUFFIX; | |
312 | $me->{thousands_sep} ||= $me->{mon_thousands_sep}; | |
313 | $me->{decimal_point} ||= $me->{mon_decimal_point}; | |
314 | ||
315 | # Override if given as arguments | |
316 | foreach $arg (qw(thousands_sep decimal_point mon_thousands_sep | |
317 | mon_decimal_point int_curr_symbol decimal_digits | |
318 | decimal_fill neg_format kilo_suffix mega_suffix | |
319 | giga_suffix)) | |
320 | { | |
321 | foreach ($arg, uc $arg, "-$arg", uc "-$arg") | |
322 | { | |
323 | next unless defined $args{$_}; | |
324 | $me->{$arg} = $args{$_}; | |
325 | delete $args{$_}; | |
326 | last; | |
327 | } | |
328 | } | |
329 | croak "Invalid args: ".join(',', keys %args)."\n" if %args; | |
330 | bless $me, $type; | |
331 | $me; | |
332 | } | |
333 | ||
334 | ##---------------------------------------------------------------------- | |
335 | ||
336 | =item round($number, $precision) | |
337 | ||
338 | Rounds the number to the specified precision. If C<$precision> is | |
339 | omitted, the value of the C<DECIMAL_DIGITS> parameter is used (default | |
340 | value 2). Both input and output are numeric (the function uses math | |
341 | operators rather than string manipulation to do its job), The value of | |
342 | C<$precision> may be any integer, positive or negative. Examples: | |
343 | ||
344 | round(3.14159) yields 3.14 | |
345 | round(3.14159, 4) yields 3.1416 | |
346 | round(42.00, 4) yields 42 | |
347 | round(1234, -2) yields 1200 | |
348 | ||
349 | Since this is a mathematical rather than string oriented function, | |
350 | there will be no trailing zeroes to the right of the decimal point, | |
351 | and the C<DECIMAL_POINT> and C<THOUSANDS_SEP> variables are ignored. | |
352 | To format your number using the C<DECIMAL_POINT> and C<THOUSANDS_SEP> | |
353 | variables, use C<format_number()> instead. | |
354 | ||
355 | =cut | |
356 | ||
357 | sub round | |
358 | { | |
359 | my ($self, $number, $precision) = _get_self @_; | |
360 | $precision = $self->{decimal_digits} unless defined $precision; | |
361 | $precision = 2 unless defined $precision; | |
362 | $number = 0 unless defined $number; | |
363 | ||
364 | my $sign = $number <=> 0; | |
365 | my $multiplier = (10 ** $precision); | |
366 | my $result = abs($number); | |
367 | $result = int(($result * $multiplier) + .5000001) / $multiplier; | |
368 | $result = -$result if $sign < 0; | |
369 | return $result; | |
370 | } | |
371 | ||
372 | ##---------------------------------------------------------------------- | |
373 | ||
374 | =item format_number($number, $precision, $trailing_zeroes) | |
375 | ||
376 | Formats a number by adding C<THOUSANDS_SEP> between each set of 3 | |
377 | digits to the left of the decimal point, substituting C<DECIMAL_POINT> | |
378 | for the decimal point, and rounding to the specified precision using | |
379 | C<round()>. Note that C<$precision> is a I<maximum> precision | |
380 | specifier; trailing zeroes will only appear in the output if | |
381 | C<$trailing_zeroes> is provided, or the parameter C<DECIMAL_FILL> is | |
382 | set, with a value that is true (not zero, undef, or the empty string). | |
383 | If C<$precision> is omitted, the value of the C<DECIMAL_DIGITS> | |
384 | parameter (default value of 2) is used. Examples: | |
385 | ||
386 | format_number(12345.6789) yields '12,345.68' | |
387 | format_number(123456.789, 2) yields '123,456.79' | |
388 | format_number(1234567.89, 2) yields '1,234,567.89' | |
389 | format_number(1234567.8, 2) yields '1,234,567.8' | |
390 | format_number(1234567.8, 2, 1) yields '1,234,567.80' | |
391 | format_number(1.23456789, 6) yields '1.234568' | |
392 | ||
393 | Of course the output would have your values of C<THOUSANDS_SEP> and | |
394 | C<DECIMAL_POINT> instead of ',' and '.' respectively. | |
395 | ||
396 | =cut | |
397 | ||
398 | sub format_number | |
399 | { | |
400 | my ($self, $number, $precision, $trailing_zeroes) = _get_self @_; | |
401 | $self->_check_seps(); # first make sure the SEP variables are valid | |
402 | ||
403 | # Set defaults and standardize number | |
404 | $precision = $self->{decimal_digits} unless defined $precision; | |
405 | $trailing_zeroes = $self->{decimal_fill} unless defined $trailing_zeroes; | |
406 | ||
407 | # Handle negative numbers | |
408 | my $sign = $number <=> 0; | |
409 | $number = abs($number) if $sign < 0; | |
410 | $number = $self->round($number, $precision); # round off $number | |
411 | ||
412 | # Split integer and decimal parts of the number and add commas | |
413 | my $integer = int($number); | |
414 | my $decimal; | |
415 | ||
416 | # Note: In perl 5.6 and up, string representation of a number | |
417 | # automagically includes the locale decimal point. This way we | |
418 | # will detect the decimal part correctly as long as the decimal | |
419 | # point is 1 character. | |
420 | $decimal = substr($number, length($integer)+1) | |
421 | if (length($integer) < length($number)); | |
422 | $decimal = '' unless defined $decimal; | |
423 | ||
424 | # Add trailing 0's if $trailing_zeroes is set. | |
425 | $decimal .= '0'x( $precision - length($decimal) ) | |
426 | if $trailing_zeroes && $precision > length($decimal); | |
427 | ||
428 | # Add leading 0's so length($integer) is divisible by 3 | |
429 | $integer = '0'x(3 - (length($integer) % 3)).$integer; | |
430 | ||
431 | # Split $integer into groups of 3 characters and insert commas | |
432 | $integer = join($self->{thousands_sep}, | |
433 | grep {$_ ne ''} split(/(...)/, $integer)); | |
434 | ||
435 | # Strip off leading zeroes and/or comma | |
436 | $integer =~ s/^0+\Q$self->{thousands_sep}\E?//; | |
437 | $integer = '0' if $integer eq ''; | |
438 | ||
439 | # Combine integer and decimal parts and return the result. | |
440 | my $result = ((defined $decimal && length $decimal) ? | |
441 | join($self->{decimal_point}, $integer, $decimal) : | |
442 | $integer); | |
443 | ||
444 | return ($sign < 0) ? $self->format_negative($result) : $result; | |
445 | } | |
446 | ||
447 | ##---------------------------------------------------------------------- | |
448 | ||
449 | =item format_negative($number, $picture) | |
450 | ||
451 | Formats a negative number. Picture should be a string that contains | |
452 | the letter C<x> where the number should be inserted. For example, for | |
453 | standard negative numbers you might use ``C<-x>'', while for | |
454 | accounting purposes you might use ``C<(x)>''. If the specified number | |
455 | begins with a ``-'' character, that will be removed before formatting, | |
456 | but formatting will occur whether or not the number is negative. | |
457 | ||
458 | =cut | |
459 | ||
460 | sub format_negative | |
461 | { | |
462 | my($self, $number, $format) = _get_self @_; | |
463 | $format = $self->{neg_format} unless defined $format; | |
464 | croak "Letter x must be present in picture in format_negative()\n" | |
465 | unless $format =~ /x/; | |
466 | $number =~ s/^-//; | |
467 | $format =~ s/x/$number/; | |
468 | return $format; | |
469 | } | |
470 | ||
471 | ##---------------------------------------------------------------------- | |
472 | ||
473 | =item format_picture($number, $picture) | |
474 | ||
475 | Returns a string based on C<$picture> with the C<#> characters | |
476 | replaced by digits from C<$number>. If the length of the integer part | |
477 | of $number is too large to fit, the C<#> characters are replaced with | |
478 | asterisks (C<*>) instead. Examples: | |
479 | ||
480 | format_picture(100.023, 'USD ##,###.##') yields 'USD 100.02' | |
481 | format_picture(1000.23, 'USD ##,###.##') yields 'USD 1,000.23' | |
482 | format_picture(10002.3, 'USD ##,###.##') yields 'USD 10,002.30' | |
483 | format_picture(100023, 'USD ##,###.##') yields 'USD **,***.**' | |
484 | format_picture(1.00023, 'USD #.###,###') yields 'USD 1.002,300' | |
485 | ||
486 | The comma (,) and period (.) you see in the picture examples should | |
487 | match the values of C<THOUSANDS_SEP> and C<DECIMAL_POINT>, | |
488 | respectively, for proper operation. However, the C<THOUSANDS_SEP> | |
489 | characters in C<$picture> need not occur every three digits; the | |
490 | I<only> use of that variable by this function is to remove leading | |
491 | commas (see the first example above). There may not be more than one | |
492 | instance of C<DECIMAL_POINT> in C<$picture>. | |
493 | ||
494 | The value of C<NEG_FORMAT> is used to determine how negative numbers | |
495 | are displayed. The result of this is that the output of this function | |
496 | my have unexpected spaces before and/or after the number. This is | |
497 | necessary so that positive and negative numbers are formatted into a | |
498 | space the same size. If you are only using positive numbers and want | |
499 | to avoid this problem, set NEG_FORMAT to "x". | |
500 | ||
501 | =cut | |
502 | ||
503 | sub format_picture | |
504 | { | |
505 | my ($self, $number, $picture) = _get_self @_; | |
506 | $self->_check_seps(); | |
507 | ||
508 | # Handle negative numbers | |
509 | my($neg_prefix) = $self->{neg_format} =~ /^([^x]+)/; | |
510 | my($pic_prefix) = $picture =~ /^([^\#]+)/; | |
511 | my $neg_pic = $self->{neg_format}; | |
512 | (my $pos_pic = $self->{neg_format}) =~ s/[^x\s]/ /g; | |
513 | (my $pos_prefix = $neg_prefix) =~ s/[^x\s]/ /g; | |
514 | $neg_pic =~ s/x/$picture/; | |
515 | $pos_pic =~ s/x/$picture/; | |
516 | my $sign = $number <=> 0; | |
517 | $number = abs($number) if $sign < 0; | |
518 | $picture = $sign < 0 ? $neg_pic : $pos_pic; | |
519 | my $sign_prefix = $sign < 0 ? $neg_prefix : $pos_prefix; | |
520 | ||
521 | # Split up the picture and die if there is more than one $DECIMAL_POINT | |
522 | my($pic_int, $pic_dec, @cruft) = | |
523 | split(/\Q$self->{decimal_point}\E/, $picture); | |
524 | $pic_int = '' unless defined $pic_int; | |
525 | $pic_dec = '' unless defined $pic_dec; | |
526 | ||
527 | croak("Number::Format::format_picture($number, $picture): ". | |
528 | "Only one decimal separator($self->{decimal_point}) ". | |
529 | "permitted in picture.\n") | |
530 | if @cruft; | |
531 | ||
532 | # Obtain precision from the length of the decimal part... | |
533 | my $precision = $pic_dec; # start with copying it | |
534 | $precision =~ s/[^\#]//g; # eliminate all non-# characters | |
535 | $precision = length $precision; # take the length of the result | |
536 | ||
537 | # Format the number | |
538 | $number = $self->round($number, $precision); | |
539 | ||
540 | # Obtain the length of the integer portion just like we did for $precision | |
541 | my $intsize = $pic_int; # start with copying it | |
542 | $intsize =~ s/[^\#]//g; # eliminate all non-# characters | |
543 | $intsize = length $intsize; # take the length of the result | |
544 | ||
545 | # Split up $number same as we did for $picture earlier | |
546 | my($num_int, $num_dec) = split(/\./, $number, 2); | |
547 | $num_int = '' unless defined $num_int; | |
548 | $num_dec = '' unless defined $num_dec; | |
549 | ||
550 | # Check if the integer part will fit in the picture | |
551 | if (length $num_int > $intsize) | |
552 | { | |
553 | $picture =~ s/\#/\*/g; # convert # to * and return it | |
554 | $picture =~ s/^(\Q$sign_prefix\E)(\Q$pic_prefix\E)(\s*)/$2$3$1/; | |
555 | return $picture; | |
556 | } | |
557 | ||
558 | # Split each portion of number and picture into arrays of characters | |
559 | my @num_int = split(//, $num_int); | |
560 | my @num_dec = split(//, $num_dec); | |
561 | my @pic_int = split(//, $pic_int); | |
562 | my @pic_dec = split(//, $pic_dec); | |
563 | ||
564 | # Now we copy those characters into @result. | |
565 | my @result; | |
566 | @result = ($self->{decimal_point}) | |
567 | if $picture =~ /\Q$self->{decimal_point}\E/; | |
568 | # For each characture in the decimal part of the picture, replace '#' | |
569 | # signs with digits from the number. | |
570 | my $char; | |
571 | foreach $char (@pic_dec) | |
572 | { | |
573 | $char = (shift(@num_dec) || 0) if ($char eq '#'); | |
574 | push (@result, $char); | |
575 | } | |
576 | ||
577 | # For each character in the integer part of the picture (moving right | |
578 | # to left this time), replace '#' signs with digits from the number, | |
579 | # or spaces if we've run out of numbers. | |
580 | while ($char = pop @pic_int) | |
581 | { | |
582 | $char = pop(@num_int) if ($char eq '#'); | |
583 | $char = ' ' if (!defined($char) || | |
584 | $char eq $self->{thousands_sep} && $#num_int < 0); | |
585 | unshift (@result, $char); | |
586 | } | |
587 | ||
588 | # Combine @result into a string and return it. | |
589 | my $result = join('', @result); | |
590 | $sign_prefix = '' unless defined $sign_prefix; | |
591 | $pic_prefix = '' unless defined $pic_prefix; | |
592 | $result =~ s/^(\Q$sign_prefix\E)(\Q$pic_prefix\E)(\s*)/$2$3$1/; | |
593 | $result; | |
594 | } | |
595 | ||
596 | ##---------------------------------------------------------------------- | |
597 | ||
598 | =item format_price($number, $precision) | |
599 | ||
600 | Returns a string containing C<$number> formatted similarly to | |
601 | C<format_number()>, except that the decimal portion may have trailing | |
602 | zeroes added to make it be exactly C<$precision> characters long, and | |
603 | the currency string will be prefixed. | |
604 | ||
605 | If the C<INT_CURR_SYMBOL> attribute of the object is the empty string, no | |
606 | currency will be added. | |
607 | ||
608 | If C<$precision> is not provided, the default of 2 will be used. | |
609 | Examples: | |
610 | ||
611 | format_price(12.95) yields 'USD 12.95' | |
612 | format_price(12) yields 'USD 12.00' | |
613 | format_price(12, 3) yields '12.000' | |
614 | ||
615 | The third example assumes that C<INT_CURR_SYMBOL> is the empty string. | |
616 | ||
617 | =cut | |
618 | ||
619 | sub format_price | |
620 | { | |
621 | my ($self, $number, $precision) = _get_self @_; | |
622 | $precision = $self->{decimal_digits} unless defined $precision; | |
623 | $precision = 2 unless defined $precision; # default | |
624 | ||
625 | my $sign = $number <=> 0; | |
626 | $number = abs($number) if $sign < 0; | |
627 | ||
628 | $number = $self->format_number($number, $precision); # format it first | |
629 | # Now we make sure the decimal part has enough zeroes | |
630 | my ($integer, $decimal) = | |
631 | split(/\Q$self->{mon_decimal_point}\E/, $number, 2); | |
632 | $decimal = '0'x$precision unless $decimal; | |
633 | $decimal .= '0'x($precision - length $decimal); | |
634 | ||
635 | # Combine it all back together and return it. | |
636 | $self->{int_curr_symbol} =~ s/\s*$/ /; | |
637 | my $result = ($self->{int_curr_symbol} . | |
638 | ($precision ? | |
639 | join($self->{mon_decimal_point}, $integer, $decimal) : | |
640 | $integer)); | |
641 | ||
642 | return ($sign < 0) ? $self->format_negative($result) : $result; | |
643 | } | |
644 | ||
645 | ##---------------------------------------------------------------------- | |
646 | ||
647 | =item format_bytes($number, $precision) | |
648 | ||
649 | Returns a string containing C<$number> formatted similarly to | |
650 | C<format_number()>, except that if the number is over 1024, it will be | |
651 | divided by 1024 and "K" appended to the end; or if it is over 1048576 | |
652 | (1024*1024), it will be divided by 1048576 and "M" appended to the | |
653 | end. Negative values will result in an error. | |
654 | ||
655 | If C<$precision> is not provided, the default of 2 will be used. | |
656 | Examples: | |
657 | ||
658 | format_bytes(12.95) yields '12.95' | |
659 | format_bytes(2048) yields '2K' | |
660 | format_bytes(1048576) yields '1M' | |
661 | ||
662 | =cut | |
663 | ||
664 | sub format_bytes | |
665 | { | |
666 | my ($self, $number, $precision) = _get_self @_; | |
667 | $precision = $self->{decimal_digits} unless defined $precision; | |
668 | $precision = 2 unless defined $precision; # default | |
669 | croak "Negative number ($number) not allowed in format_bytes\n" | |
670 | if $number < 0; | |
671 | my $suffix = ""; | |
672 | if ($number > 0x40000000) | |
673 | { | |
674 | $number /= 0x40000000; | |
675 | $suffix = $self->{giga_suffix}; | |
676 | } | |
677 | elsif ($number > 0x100000) | |
678 | { | |
679 | $number /= 0x100000; | |
680 | $suffix = $self->{mega_suffix}; | |
681 | } | |
682 | elsif ($number > 0x400) | |
683 | { | |
684 | $number /= 0x400; | |
685 | $suffix = $self->{kilo_suffix}; | |
686 | } | |
687 | ||
688 | $number = $self->format_number($number, $precision); # format it first | |
689 | ||
690 | # Combine it all back together and return it. | |
691 | return $number.$suffix; | |
692 | } | |
693 | ||
694 | ##---------------------------------------------------------------------- | |
695 | ||
696 | =item unformat_number($formatted) | |
697 | ||
698 | Converts a string as returned by C<format_number()>, | |
699 | C<format_price()>, or C<format_picture()>, and returns the | |
700 | corresponding value as a numeric scalar. Returns C<undef> if the | |
701 | number does not contain any digits. Examples: | |
702 | ||
703 | unformat_number('USD 12.95') yields 12.95 | |
704 | unformat_number('USD 12.00') yields 12 | |
705 | unformat_number('foobar') yields undef | |
706 | unformat_number('1234-567@.8') yields 1234567.8 | |
707 | ||
708 | The value of C<DECIMAL_POINT> is used to determine where to separate | |
709 | the integer and decimal portions of the input. All other non-digit | |
710 | characters, including but not limited to C<INT_CURR_SYMBOL> and | |
711 | C<THOUSANDS_SEP>, are removed. | |
712 | ||
713 | If the number matches the pattern of C<NEG_FORMAT> I<or> there is a | |
714 | ``-'' character before any of the digits, then a negative number is | |
715 | returned. | |
716 | ||
717 | If the number ends with the C<KILO_SUFFIX> or C<MEGA_SUFFIX> | |
718 | characters, then the number returned will be multiplied by 1024 or | |
719 | 1024*1024 as appropriate. | |
720 | ||
721 | =cut | |
722 | ||
723 | sub unformat_number | |
724 | { | |
725 | my ($self, $formatted) = _get_self @_; | |
726 | $self->_check_seps(); | |
727 | return undef unless $formatted =~ /\d/; # require at least one digit | |
728 | ||
729 | # Detect if it ends with the kilo or mega suffix. | |
730 | my $kp = ($formatted =~ s/$self->{kilo_suffix}\s*$//); | |
731 | my $mp = ($formatted =~ s/$self->{mega_suffix}\s*$//); | |
732 | ||
733 | # Split number into integer and decimal parts | |
734 | my ($integer, $decimal, @cruft) = | |
735 | split(/\Q$self->{decimal_point}\E/, $formatted); | |
736 | croak("Number::Format::unformat_number($formatted): ". | |
737 | "Only one decimal separator($self->{decimal_point}) permitted.\n") | |
738 | if @cruft; | |
739 | ||
740 | # It's negative if the first non-digit character is a - | |
741 | my $sign = $formatted =~ /^\D*-/ ? -1 : 1; | |
742 | my($before_re, $after_re) = split /x/, $self->{neg_format}, 2; | |
743 | $sign = -1 if $formatted =~ /\Q$before_re\E(.+)\Q$after_re\E/; | |
744 | ||
745 | # Strip out all non-digits from integer and decimal parts | |
746 | $integer = '' unless defined $integer; | |
747 | $decimal = '' unless defined $decimal; | |
748 | $integer =~ s/\D//g; | |
749 | $decimal =~ s/\D//g; | |
750 | ||
751 | # Join back up, using period, and add 0 to make Perl think it's a number | |
752 | my $number = join('.', $integer, $decimal) + 0; | |
753 | $number = -$number if $sign < 0; | |
754 | ||
755 | # Scale the number if it ended in kilo or mega suffix. | |
756 | $number *= 1024 if $kp; | |
757 | $number *= 1048576 if $mp; | |
758 | ||
759 | return $number; | |
760 | } | |
761 | ||
762 | ###--------------------------------------------------------------------- | |
763 | ||
764 | =back | |
765 | ||
766 | =head1 BUGS | |
767 | ||
768 | No known bugs at this time. Please report any problems to the author. | |
769 | ||
770 | =head1 AUTHOR | |
771 | ||
772 | William R. Ward, wrw@bayview.com | |
773 | ||
774 | =head1 SEE ALSO | |
775 | ||
776 | perl(1). | |
777 | ||
778 | =cut | |
779 | ||
780 | 1; |