File Coverage

blib/lib/Interchange6/Currency.pm
Criterion Covered Total %
statement 93 95 97.8
branch 24 26 96.1
condition 0 3 0.0
subroutine 27 28 96.4
pod 12 12 100.0
total 156 164 95.7


line stmt bran cond sub pod time code
1             package Interchange6::Currency;
2              
3             =head1 NAME
4              
5             Interchange6::Currency - Currency objects for Interchange 6
6              
7             =head1 VERSION
8              
9             0.101
10              
11             =for stopwords CLDR eCommerce Mottram Shutterstock SysPete
12              
13             =cut
14              
15             our $VERSION = '0.101';
16              
17 2     2   65781 use Moo;
  2         30274  
  2         12  
18             extends 'CLDR::Number::Format::Currency';
19              
20 2     2   3291 use Carp;
  2         3  
  2         146  
21 2     2   1544 use Class::Load qw/load_class/;
  2         41662  
  2         122  
22 2     2   3160 use Math::BigFloat;
  2         43785  
  2         9  
23 2     2   102838 use Safe::Isa;
  2         929  
  2         232  
24 2     2   1474 use Sub::Quote qw/quote_sub/;
  2         7502  
  2         127  
25 2     2   1703 use namespace::clean;
  2         12958  
  2         11  
26             use overload
27 0     0   0 '0+' => sub { shift->value },
28 52     52   33138 '""' => sub { shift->as_string },
29 2         39 '+' => \&_add,
30             '-' => \&_subtract,
31             '*' => \&_multiply,
32             '/' => \&_divide,
33             '%' => \&modulo,
34             '<=>' => \&cmp_value,
35             'cmp' => \&cmp,
36             '=' => \&clone,
37 2     2   830 ;
  2         4  
38              
39             =head1 DESCRIPTION
40              
41             Currency objects for Interchange6 Open Source eCommerce with Unicode
42             CLDR localization and rate conversion.
43              
44             Extends L with accurate calculation functions
45             using L.
46              
47             Many useful standard operators are overloaded and return currency objects
48             if appropriate.
49              
50             Although this class was written to satisfy the specific requirements of
51             Interchange6 it is suitable for use as a standalone module. See L
52             for other currency modules.
53              
54             =head1 ATTRIBUTES
55              
56             =head2 value
57              
58             Value as simple decimal, e.g.: 3.45
59              
60             All values are coerced into L.
61              
62             =cut
63              
64             has value => (
65             is => 'rwp',
66             required => 1,
67             coerce => quote_sub(q{ $_[0]->$_isa("Math::BigFloat") ? $_[0] : Math::BigFloat->new( $_[0] ) }),
68             );
69              
70             # check for currency objects with different currency codes and if arg
71             # is a currency object return its value
72             sub _clean_arg {
73 78     78   713 my ( $self, $arg ) = @_;
74              
75             # uncoverable branch true
76 78 50       245 croak "_clean_arg is a class method" unless $self->$_isa(__PACKAGE__);
77              
78 78 100       1075 if ( $arg->$_isa(__PACKAGE__) ) {
79 19 100       668 croak "Cannot perform calculation when currencies do not match"
80             if $self->currency_code ne $arg->currency_code;
81 12         174 return $arg->value;
82             }
83 59         627 return $arg;
84             }
85              
86             =head2 converter_class
87              
88             Defaults to L.
89              
90             The class name which handles conversion to a new C.
91              
92             The converter class can be any class that supports the following method
93             signature:
94              
95             sub convert {
96             my ($self, $price, $from, $to) = @_;
97            
98             return $converted_price;
99             };
100              
101             In addition this module supports the following converters:
102              
103             =over
104              
105             =item * L
106              
107             =back
108              
109             =cut
110              
111             has converter_class => (
112             is => 'ro',
113             isa => quote_sub(q{ die "$_[0] is not a valid class name" unless ( ref(\$_[0]) eq 'SCALAR' && $_[0] =~ /^\S+$/ ) }),
114             default => "Finance::Currency::Convert::WebserviceX",
115             );
116              
117             =head2 converter
118              
119             Vivified L.
120              
121             =cut
122              
123             has converter => (
124             is => 'lazy',
125             isa => quote_sub(q{ die "Not a valid converter class" unless $_[0]->$_can('convert') }),
126             init_arg => undef,
127             );
128              
129             sub _build_converter {
130 4     4   807 my $self = shift;
131 4         21 load_class( $self->converter_class );
132 3         1307 return $self->converter_class->new;
133             }
134              
135             =head1 METHODS
136              
137             =head2 BUILD
138              
139             Sets precision for automatic rounding of L to
140             L.
141              
142             =cut
143              
144             sub BUILD {
145 43     43 1 134097 my $self = shift;
146              
147             # force cash trigger so we can reset precision on value
148 43         834 $self->cash( $self->cash );
149 43         19930 $self->value->precision( -$self->maximum_fraction_digits );
150             }
151              
152             =head2 clone %new_attrs?
153              
154             Returns clone of the currency object possibly with new attribute values (if
155             any are supplied).
156              
157             =cut
158              
159             sub clone {
160 34     34 1 3949 my ( $self, %new_attrs ) = @_;
161 34         876 return __PACKAGE__->new(
162             value => $self->value,
163             currency_code => $self->currency_code,
164             locale => $self->locale,
165             %new_attrs,
166             );
167             }
168              
169             =head2 convert $new_corrency_code
170              
171             Convert to new currency using L.
172              
173             B If C is called in void context then the currency object
174             is mutated in place. If called in list or scalar context then the original
175             object is not modified and a new L object is returned
176             instead.
177              
178             =cut
179              
180             sub convert {
181 11     11 1 12957 my ( $self, $new_code ) = @_;
182              
183 11 100       305 if ( $self->currency_code eq $new_code ) {
184              
185             # currency code has not changed
186 2 100       18 if ( defined wantarray ) {
187              
188             # called in list or scalar context
189 1         4 return $self->clone;
190             }
191             else {
192              
193             # void context
194 1         6 return;
195             }
196             }
197             else {
198              
199             # remove precision before conversion since new currency may have
200             # different maximum_fraction_digits and we don't want to lose accuracy
201 9         99 $self->value->precision(undef);
202              
203             # currency code has changed so convert via converter_class
204              
205 9         141 my $new_value;
206              
207 9 50       32 if ( $self->converter_class eq 'Finance::Currency::Convert::XE' ) {
208              
209             # XE is special
210 0   0     0 $new_value = $self->converter->convert(
211             value => $self->value,
212             source => $self->currency_code,
213             target => $new_code
214             ) || croak "convert failed: " . $self->converter->error . "\n";
215             }
216             else {
217             # other
218 9         175 $new_value =
219             $self->converter->convert( $self->value, $self->currency_code,
220             $new_code );
221             }
222              
223 8 100       2848 croak "convert failed" unless defined $new_value;
224              
225 7 100       20 if ( defined wantarray ) {
226              
227             # called in list or scalar context
228              
229 5         16 return $self->clone(
230             currency_code => $new_code,
231             value => $new_value,
232             );
233             }
234             else {
235              
236             # void context
237              
238 2         47 $self->currency_code($new_code);
239 2         1269 $self->_set_value($new_value);
240              
241             # force cash trigger so we can reset precision on value
242 2         797 $self->cash( $self->cash );
243 2         951 $self->value->precision( -$self->maximum_fraction_digits );
244              
245 2         414 return;
246             }
247             }
248             }
249              
250             =head2 as_string
251              
252             Stringified formatted currency, e.g.: $3.45
253              
254             =cut
255              
256             sub as_string {
257 74     74 1 30415 return $_[0]->format( $_[0]->value );
258             }
259              
260             =head2 stringify
261              
262             Alias for L.
263              
264             =cut
265              
266             sub stringify {
267 1     1 1 2437 return $_[0]->as_string;
268             }
269              
270             =head2 add $arg
271              
272             Add C<$arg> to L in place.
273              
274             =cut
275              
276             sub add {
277 3     3 1 7634 my ( $self, $arg ) = @_;
278 3         15 $self->value->badd( $self->_clean_arg($arg) );
279             }
280              
281             # for overloaded '+'
282             sub _add {
283 8     8   13011 my ( $self, $arg ) = @_;
284 8         41 $self->clone(
285             value => $self->value->copy->badd( $self->_clean_arg($arg) ) );
286             }
287              
288             =head2 subtract $arg
289              
290             Subtract C<$arg> from L in place.
291              
292             =cut
293              
294             sub subtract {
295 3     3 1 4065 my ( $self, $arg ) = @_;
296 3         13 $self->value->bsub( $self->_clean_arg($arg) );
297             }
298              
299             # for overloaded '-'
300             sub _subtract {
301 8     8   9627 my ( $self, $arg, $swap ) = @_;
302 8         40 my $result = $self->value->copy->bsub( $self->_clean_arg($arg) );
303 8 100       3331 $self->clone( value => $swap ? $result->bneg : $result );
304             }
305              
306             =head2 multiply $arg
307              
308             Multiply L by C<$arg> in place.
309              
310             =cut
311              
312             sub multiply {
313 3     3 1 3985 my ( $self, $arg ) = @_;
314 3         13 $self->value->bmul( $self->_clean_arg($arg) );
315             }
316              
317             # for overloaded '*'
318             sub _multiply {
319 2     2   2871 my ( $self, $arg ) = @_;
320 2         11 $self->clone(
321             value => $self->value->copy->bmul( $self->_clean_arg($arg) ) );
322             }
323              
324             =head2 divide $arg
325              
326             Divide L by C<$arg> in place.
327              
328             =cut
329              
330             sub divide {
331 3     3 1 3998 my ( $self, $arg ) = @_;
332 3         14 $self->value->bdiv( $self->_clean_arg($arg) );
333             }
334              
335             # for overloaded '/'
336             sub _divide {
337 5     5   6979 my ( $self, $arg, $swap ) = @_;
338 5         10 my $result;
339 5 100       12 if ($swap) {
340 1         5 $result =
341             Math::BigFloat->new( $self->_clean_arg($arg) )->bdiv( $self->value );
342             }
343             else {
344 4         22 $result = $self->value->copy->bdiv( $self->_clean_arg($arg) );
345             }
346 5         3089 $self->clone( value => $result );
347             }
348              
349             =head2 modulo $arg
350              
351             Return L C<%> C<$arg> as currency object.
352              
353             =cut
354              
355             sub modulo {
356 6     6 1 7643 my ( $self, $arg, $swap ) = @_;
357 6         7 my $result;
358 6 100       16 if ($swap) {
359 1         5 $result =
360             Math::BigFloat->new( $self->_clean_arg($arg) )->bmod( $self->value );
361             }
362             else {
363 5         26 $result = $self->value->copy->bmod( $self->_clean_arg($arg) );
364             }
365 5         2222 $self->clone( value => $result );
366             }
367              
368             =head2 cmp_value $arg
369              
370             Equivalent to L C<< <=> >> C<$arg>.
371              
372             =cut
373              
374             sub cmp_value {
375 37     37 1 29159 my ( $self, $arg, $swap ) = @_;
376 37 100       91 if ($swap) {
377 3         8 return Math::BigFloat->new( $self->_clean_arg($arg) )
378             ->bcmp( $self->value );
379             }
380             else {
381 34         112 return $self->value->bcmp( $self->_clean_arg($arg) );
382             }
383             }
384              
385             =head2 cmp $arg
386              
387             String comparison.
388              
389             Not always useful in itself since string comparison of stringified currency
390             objects might not produce what you expect depending on locale and currency
391             code.
392              
393             =cut
394              
395             sub cmp {
396 29     29 1 24807 my ( $self, $arg, $swap ) = @_;
397 29 100       66 if ($swap) {
398 3         10 return "$arg" cmp "$self";
399             }
400             else {
401 26         67 return "$self" cmp "$arg";
402             }
403             }
404              
405             =head2 SEE ALSO
406              
407             Other modules which perform currency maths:
408              
409             =over
410              
411             =item * L
412              
413             =item * L
414              
415             =back
416              
417             Other Interchange6 eCommerce modules:
418              
419             =over
420              
421             =item * L
422              
423             =item * L
424              
425             =item * L
426              
427             =back
428              
429             =head1 AUTHORS
430              
431             Peter Mottram (SysPete), C
432              
433             =head1 ACKNOWLEDGEMENTS
434              
435             Shutterstock, Inc for the excellent L and all of the authors
436             of L and L.
437              
438             =head1 LICENSE AND COPYRIGHT
439              
440             Copyright 2015-2016 Peter Mottram (SysPete).
441              
442             This program is free software; you can redistribute it and/or modify it
443             under the terms of either: the GNU General Public License as published
444             by the Free Software Foundation; or the Artistic License.
445              
446             See http://dev.perl.org/licenses/ for more information.
447              
448             Unicode is a registered trademark of Unicode, Inc., in the United States
449             and other countries.
450              
451             =cut
452              
453             1;