File Coverage

blib/lib/Locale/Object/Currency.pm
Criterion Covered Total %
statement 115 115 100.0
branch 29 34 85.2
condition 1 3 33.3
subroutine 19 19 100.0
pod 8 10 80.0
total 172 181 95.0


line stmt bran cond sub pod time code
1             package Locale::Object::Currency;
2              
3 7     7   291873 use strict;
  7         30  
  7         197  
4 7     7   33 use warnings;;
  7         11  
  7         189  
5 7     7   29 use Carp;
  7         12  
  7         415  
6              
7 7     7   898 use Locale::Object;
  7         14  
  7         186  
8 7     7   39 use base qw( Locale::Object );
  7         12  
  7         1013  
9              
10 7     7   45 use Locale::Object::Country;
  7         15  
  7         182  
11 7     7   36 use Locale::Object::DB;
  7         18  
  7         6296  
12              
13             our $VERSION = '0.78';
14              
15             my $db = Locale::Object::DB->new();
16              
17             # Initialize the hash where we'll keep our singleton currency objects.
18             my $existing = {};
19              
20             my $class;
21              
22             # Initialize the object.
23             sub init
24             {
25 376     376 0 565 my $self = shift;
26 376         715 my %params = @_;
27              
28             # One parameter is allowed.
29 376 50       793 croak "Error: You must specify a single parameter for initialization."
30             unless scalar(keys %params) == 1;
31              
32             # It's the only key in %params.
33 376         734 my $parameter = (keys %params)[0];
34            
35             # Make a hash of valid parameters.
36 376         686 my %allowed_params = map { $_ => undef }
  1128         2347  
37             qw(country_code code code_numeric);
38            
39             # Go no further if the specified parameter wasn't one.
40 376 50       868 croak "Error: You can only specify a country code, currency code or numeric code for initialization." unless exists $allowed_params{$parameter};
41              
42             # Get the value given for the parameter.
43 376         615 my $value = $params{$parameter};
44              
45             # Make sure input matches style of values in the db.
46 376 100       792 if ($parameter eq 'country_code')
    100          
47             {
48 363         681 $value = lc($value);
49             }
50             elsif ($parameter eq 'code')
51             {
52 12         65 $value = uc($value);
53             }
54            
55             # Look in the database for a match.
56 376         1122 my $result = $db->lookup(
57             table => 'currency',
58             result_column => '*',
59             search_column => $parameter,
60             value => $value
61             );
62              
63 376 50       33950 croak "Error: Unknown $parameter given for initialization: $value" unless $result;
64              
65 376 100       615 if (defined @{$result}[0])
  376         968  
66             {
67             # Set values from the results of our query.
68 375         488 my $name = @{$result}[0]->{'name'};
  375         771  
69 375         551 my $code = @{$result}[0]->{'code'};
  375         621  
70 375         504 my $code_numeric = @{$result}[0]->{'code_numeric'};
  375         541  
71 375         757 my $symbol = @{$result}[0]->{'symbol'};
  375         593  
72 375         478 my $subunit = @{$result}[0]->{'subunit'};
  375         549  
73 375         463 my $subunit_amount = @{$result}[0]->{'subunit_amount'};
  375         544  
74            
75             # Check for pre-existing objects. Return it if there is one.
76 375         863 my $currency = $self->exists($code);
77 375 100       1470 return $currency if $currency;
78            
79             # If not, make a new object.
80 288         668 _make_currency($self, $name, $code, $code_numeric, $symbol, $subunit, $subunit_amount);
81            
82             # Register the new object.
83 288         626 $self->register();
84            
85             # Return the object.
86 288         2544 $self;
87             }
88             else
89             {
90 1         204 carp "Warning: No result found in currency table for '$value' in $parameter.";
91 1         11 return;
92             }
93             }
94              
95             # Check if objects exist.
96             sub exists {
97 375     375 1 505 my $self = shift;
98            
99             # Check existence of a object with the given parameter or with
100             # the code of the current object.
101 375   33     799 my $code = shift || $self->code;
102            
103             # Return the singleton object, if it exists.
104 375         825 $existing->{$code};
105             }
106              
107             # Register the object in our hash of existing objects.
108             sub register {
109 288     288 0 376 my $self = shift;
110            
111             # Do nothing unless the object exists.
112 288 50       460 my $code = $self->code or return;
113            
114             # Put the current object into the singleton hash.
115 288         712 $existing->{$code} = $self;
116             }
117              
118             sub _make_currency
119             {
120 288     288   400 my $self = shift;
121 288         773 my @attributes = @_;
122              
123             # The third attribute we get is the currency code.
124 288         435 my $currency_code = $attributes[0];
125            
126             # The attributes we want to set.
127 288         689 my @attr_names = qw(name code code_numeric symbol subunit subunit_amount);
128            
129             # Initialize a loop counter.
130 288         375 my $counter = 0;
131            
132 288         566 foreach my $current_attribute (@attr_names)
133             {
134             # Set the attributes of the entry for this currency code in the singleton hash.
135 1728         3998 $self->$current_attribute( $attributes[$counter] );
136            
137 1728         2412 $counter++;
138             }
139              
140             }
141              
142             # Method for retrieving all countries using this currency.
143             sub countries
144             {
145 8     8 1 13 my $self = shift;
146            
147             # No name, no countries.
148 8 50       27 return unless $self->{_name};
149            
150             # Check for countries attribute. Set it if we don't have it.
151 8 100       26 _set_countries($self) unless $self->{_countries};
152              
153             # Give an array if requested in array context, otherwise a reference.
154 8 100       22 return @{$self->{_countries}} if wantarray;
  6         20  
155 2         10 return $self->{_countries};
156             }
157              
158             # Private method to set an attribute with a hash of objects for all countries using this currency.
159             sub _set_countries
160             {
161 5     5   8 my $self = shift;
162              
163 5         10 my $code = $self->{_code};
164            
165             # If it doesn't, find all countries using this currency and put them in a hash.
166 5         11 my (%country_codes, @countries);
167            
168             my $result = $db->lookup(
169             table => "currency",
170             result_column => "country_code",
171             search_column => "code",
172 5         23 value => $existing->{$code}->{'_code'}
173             );
174            
175             # Create new country objects and put them into an array.
176 5         496 foreach my $place (@{$result})
  5         15  
177             {
178 21         47 my $where = $place->{'country_code'};
179            
180 21         111 my $obj = Locale::Object::Country->new( code_alpha2 => $where );
181 21         60 push @countries, $obj;
182             }
183            
184             # Set a reference to that array as an attribute.
185 5         23 $self->{'_countries'} = \@countries;
186             }
187              
188             # Get/set attributes.
189              
190             sub code
191             {
192 590     590 1 715 my $self = shift;
193              
194 590 100       1052 if (@_)
195             {
196 288         498 $self->{_code} = shift;
197 288         406 return $self;
198             }
199              
200 302         751 $self->{_code};
201             }
202              
203             sub name
204             {
205 292     292 1 9848 my $self = shift;
206              
207 292 100       641 if (@_)
208             {
209 288         650 $self->{_name} = shift;
210 288         509 return $self;
211             }
212            
213 4         21 $self->{_name};
214             }
215              
216             sub code_numeric
217             {
218 289     289 1 390 my $self = shift;
219              
220 289 100       501 if (@_)
221             {
222 288         485 $self->{_code_numeric} = shift;
223 288         379 return $self;
224             }
225              
226 1         5 $self->{_code_numeric};
227             }
228              
229             sub symbol
230             {
231 289     289 1 363 my $self = shift;
232              
233 289 100       543 if (@_)
234             {
235 288         513 $self->{_symbol} = shift;
236 288         389 return $self;
237             }
238            
239 1         5 $self->{_symbol};
240             }
241              
242             sub subunit
243             {
244 289     289 1 389 my $self = shift;
245              
246 289 100       564 if (@_)
247             {
248 288         491 $self->{_subunit} = shift;
249 288         415 return $self;
250             }
251              
252 1         5 $self->{_subunit};
253             }
254              
255             sub subunit_amount
256             {
257 289     289 1 362 my $self = shift;
258              
259 289 100       491 if (@_)
260             {
261 288         489 $self->{_subunit_amount} = shift;
262 288         371 return $self;
263             }
264              
265 1         4 $self->{_subunit_amount};
266             }
267              
268             1;
269              
270             __END__
271              
272             =head1 NAME
273              
274             Locale::Object::Currency - currency information objects
275              
276             =head1 DESCRIPTION
277              
278             C<Locale::Object::Country> allows you to create objects containing information about countries such as their ISO codes, currencies and so on.
279              
280             =head1 SYNOPSIS
281              
282             use Locale::Object::Currency;
283              
284             my $usd = Locale::Object::Currency->new( country_code => 'us' );
285              
286             my $name = $usd->name;
287             my $code = $usd->code;
288             my $code_numeric = $usd->code_numeric;
289             my $symbol = $usd->symbol;
290             my $subunit = $usd->subunit;
291             my $subunit_amount = $usd->subunit_amount;
292            
293             my @countries = $usd->countries;
294              
295             =head1 METHODS
296              
297             =head2 C<new()>
298              
299             my $usd = Locale::Object::Currency->new( country_code => 'us' );
300              
301             The C<new> method creates an object. It takes a single-item hash as an argument - valid options to pass are ISO 3166 values - 'code' and 'code_numeric'; also 'country_code', which is an alpha2 country code. If you give a country code, a currency object will be created representing the currency of the country you specified.
302              
303             The objects created are singletons; if you try and create a currency object when one matching your specification already exists, C<new()> will return the original one.
304              
305             =head2 C<name(), code(), code_numeric(), symbol(), subunit(), subunit_amount()>
306              
307             my $name = $country->name;
308            
309             These methods retrieve the values of the attributes in the object whose name they share.
310              
311             =head2 C<countries()>
312              
313             my @countries = $usd->countries;
314              
315             Returns an array (in array context, otherwise a reference) of L<Locale::Object::Country> objects with their ISO 3166 alpha2 codes as keys for all countries using this currency in array context, or a reference in scalar context. The objects have their own attribute methods, so you can do things like this for example:
316              
317             foreach my $place (@countries)
318             {
319             print $place->name, "\n";
320             }
321            
322             Which will list you all the countries that use in that currency. See the documentation for L<Locale::Object::Country> for a listing of country attributes. Note that you can chain methods as well.
323              
324             foreach my $place (@countries)
325             {
326             print $place->continent->name, "\n";
327             }
328              
329             =head1 KNOWN BUGS
330              
331             The database of currency information is not perfect by a long stretch. If you find mistakes or missing information, please send them to the author.
332              
333             =head1 AUTHOR
334              
335             Originally by Earle Martin
336              
337             =head1 COPYRIGHT AND LICENSE
338              
339             Originally by Earle Martin. To the extent possible under law, the author has dedicated all copyright and related and neighboring rights to this software to the public domain worldwide. This software is distributed without any warranty. You should have received a copy of the CC0 Public Domain Dedication along with this software. If not, see <http://creativecommons.org/publicdomain/zero/1.0/>.
340              
341             =cut
342