File Coverage

blib/lib/Locale/Object.pm
Criterion Covered Total %
statement 142 148 95.9
branch 63 98 64.2
condition 8 20 40.0
subroutine 22 25 88.0
pod 13 17 76.4
total 248 308 80.5


line stmt bran cond sub pod time code
1             package Locale::Object;
2              
3 7     7   84539 use strict;
  7         21  
  7         205  
4 7     7   33 use warnings;
  7         10  
  7         140  
5 7     7   46 use Carp;
  7         13  
  7         447  
6              
7 7     7   2357 use Locale::Object::Continent;
  7         18  
  7         246  
8 7     7   510 use Locale::Object::Country;
  7         13  
  7         270  
9 7     7   1460 use Locale::Object::Currency;
  7         15  
  7         147  
10 7     7   1183 use Locale::Object::Language;
  7         14  
  7         10731  
11              
12             our $VERSION = '0.81_02';
13              
14             sub new
15             {
16 1171     1171 1 7185 my $class = shift;
17 1171         2804 my %params = @_;
18              
19 1171         2084 my $self = bless {}, $class;
20            
21             # Initialize the new object or return an existing one.
22 1171         3488 $self->init(%params);
23             }
24              
25             sub init
26             {
27 1     1 0 2 my $self = shift;
28 1         4 my %params = @_;
29              
30             # Make a hash of valid parameters.
31 1         3 my %allowed_params = map { $_ => undef }
  9         16  
32             qw( country_code_alpha2 country_code_alpha3 country_code_numeric
33             currency_code currency_code_numeric currency_name
34             language_code_alpha2 language_code_alpha3 language_name );
35              
36 1         5 foreach my $parameter (keys %params)
37             {
38             # Go no further if the specified parameter wasn't one.
39 3 50       10 croak "Error: Initialization parameter $parameter unrecognized." unless exists $allowed_params{$parameter};
40            
41 3         12 $self->$parameter( $params{$parameter} );
42             }
43            
44 1         9 $self;
45             }
46              
47             # Check 'sanity' of object - that is, whether attributes correspond with each other
48             # (no mixing of, say, currency from one country with language from another).
49              
50             sub sane
51             {
52 7     7 1 15 my $self = shift;
53 7         10 my $what = shift;
54              
55             # Default attribute is country.
56 7 50       16 $what = 'country' unless $what;
57            
58             # Make a hash of allowed attributes.
59 7         15 my %attributes = map { $_ => undef } qw( country currency language );
  21         47  
60              
61 7 50       18 croak "ERROR: attribute to check sanity against ($what) unrecognized, must be one of 'country', 'currency', 'language'." unless exists $attributes{$what};
62            
63             # We want to compare our selected attribute against the remaining attributes,
64             # which will be whatever's left after deleting it from our attributes list.
65 7         14 delete $attributes{$what};
66              
67 7         10 my $sanity_level = 0;
68              
69             # Compare each of the other attributes.
70 7         19 foreach (keys %attributes)
71             {
72 14 100       39 $sanity_level++ if $self->_compare( from => $_, to => $what ) == 1;
73             }
74            
75             # It's only sane if both the other attributes matched.
76 7 100       38 return 1 if $sanity_level == 2;
77            
78 3         13 0;
79             }
80              
81             # Compare object attributes against each other.
82             # Horrible, horrible code.
83              
84             sub _compare
85             {
86 14     14   16 my $self = shift;
87 14         35 my %params = @_;
88              
89 14         28 my $from = '_' . $params{from};
90 14         20 my $to = '_' . $params{to};
91            
92             # Pointless but we won't forbid it.
93 14 50       32 return 1 if $params{from} eq $params{to};
94            
95             # An empty attribute is a sane attribute.
96 14 100       33 return 1 unless $self->{$from};
97              
98 13 100       37 if ($params{to} eq 'country')
    100          
    50          
99             {
100 6         22 foreach my $place ($self->{$from}->countries)
101             {
102             # If any of the countries we're checking match the code
103             # of $self->{_country}, it's sane.
104 235 100       360 return 1 if $place->code_alpha2 eq $self->{_country}->code_alpha2;
105             }
106             }
107            
108             elsif ($params{to} eq 'language')
109             {
110 4 100       15 if ($params{from} eq 'country')
    50          
111             {
112 2         9 foreach ($self->{_country}->languages)
113             {
114             # If $self->{_language} is one of those, it's sane.
115 4 100       11 return 1 if $_->code_alpha2 eq $self->{_language}->code_alpha2;
116             }
117             }
118            
119             elsif ($params{from} eq 'currency')
120             {
121 2         3 my %languages;
122            
123             # Check the alpha2 codes of all the languages used
124             # in all the countries that use that currency.
125 2         7 foreach ($self->{_currency}->countries)
126             {
127 2         6 foreach ($_->languages)
128             {
129             # If $self->{_language}'s alpha2 code is one of those, it's sane.
130 8 100       16 return 1 if $_->code_alpha2 eq $self->{_language}->code_alpha2;
131             }
132             }
133             }
134             }
135            
136             elsif ($params{to} eq 'currency')
137             {
138 3 100       11 if ($params{from} eq 'country')
    50          
139             {
140 1         5 foreach ($self->{_currency}->countries)
141             {
142             # If any of the countries we're checking match the code
143             # of $self->{_country}, it's sane.
144 1 50       4 return 1 if $_->code_alpha2 eq $self->{_country}->code_alpha2;
145             }
146             }
147            
148             elsif ($params{from} eq 'language')
149             {
150             # Check the codes of all the currencies used
151             # in all the countries that use that language.
152 2         9 foreach ($self->{_language}->countries)
153             {
154 3         8 foreach ($_->currency)
155             {
156             # If $self->{_currency}'s code is one of those, it's sane.
157 3 100       7 return 1 if $_->code eq $self->{_currency}->code;
158             }
159             }
160             }
161             }
162            
163 6         19 0;
164             }
165              
166             # Make all the attributes kinsmen.
167              
168             sub make_sane
169             {
170 4     4 1 9 my $self = shift;
171 4         14 my %params = @_;
172              
173 4         6 my $what = $params{attribute};
174 4   100     19 my $populate = $params{populate} || 0;
175              
176             # Make a hash of allowed attributes.
177 4         9 my %attributes = map { $_ => undef } qw( country currency language );
  12         25  
178              
179             # Default attribute is country.
180 4 100       13 $what = 'country' unless $what;
181            
182 4 50       11 croak qq{ERROR: attribute to make sane with ("$what") unrecognized; must be one of "country", "currency", "language".} unless exists $attributes{$what};
183            
184             # Internal attributes start with underscores.
185 4         10 my $internal_attribute = '_' . $what;
186            
187 4 50       11 croak "ERROR: can not make sane against $what, none has been set." unless $self->{$internal_attribute};
188            
189 4         8 delete $attributes{$what};
190              
191 4 100       15 if ($what eq 'country')
    100          
    50          
192             {
193             # Set the currency attribute with the currency used by the country attribute.
194 2 50 33     13 $self->currency_code($self->{_country}->currency->code) if $self->{_currency} or $populate == 1;
195              
196             # Find the first language belonging to the country attribute that's
197             # listed as official, and set it as the language attribute.
198 2 50 33     10 if ($self->{_language} or $populate == 1)
199             {
200             $self->language_code_alpha2(
201 2         4 @{$self->{_country}->languages_official}[0]->code_alpha2
  2         9  
202             );
203             }
204             }
205             elsif ($what eq 'language')
206             {
207 1         2 my $country;
208              
209             # If the country attribute exists, check if it uses the language. If so, pick it.
210 1 50       4 if ($self->{_country})
211             {
212 1         3 foreach ($self->{_language}->countries)
213             {
214 3 50       9 $country = $_ if $self->{_country}->code_alpha2 eq $_->code_alpha2;
215             }
216             }
217            
218 1 50       3 unless (defined $country)
219             {
220             # If no country attribute exists, pick the first country that uses
221             # the language officially.
222 1         3 foreach ($self->{_language}->countries)
223             {
224 1 50       4 if ($self->{_language}->official($_) eq 'true')
225             {
226 1         2 $country = $_;
227 1         3 last;
228             }
229             }
230             }
231            
232 1 50 33     8 $self->country_code_alpha2($country->code_alpha2) if $self->{_country} or $populate == 1;
233 1 50 33     8 $self->currency_code($country->currency->code) if $self->{_currency} or $populate == 1;
234             }
235             elsif ($what eq 'currency')
236             {
237 1         2 my ($country, $language);
238              
239             # Try and cross-reference against language.
240 1 50       3 if ($self->{_language})
241             {
242 1         5 foreach ($self->{_language}->countries)
243             {
244             # If the currency of a country using our language
245             # matches our currency attribute, pick that country.
246             $country = $_ if ($_->currency->code eq $self->{_currency}->code)
247 1 50       4 }
248             }
249              
250             # If the preceding didn't find a country, get the first one to use the currency.
251 1 50       4 $country = @{$self->{_currency}->countries}[0] unless defined $country;
  1         3  
252              
253             # Get the first official language of that country.
254 1         2 $language = @{$country->languages_official}[0];
  1         4  
255              
256 1 50 33     8 $self->country_code_alpha2($country->code_alpha2) if $self->{_country} or $populate == 1;
257 1 50 33     5 $self->language_code_alpha2($language->code_alpha2) if $self->{_language} or $populate == 1;
258             }
259            
260 4         42 $self;
261             }
262              
263             # Remove attributes.
264             sub empty
265             {
266 1     1 1 2 my $self = shift;
267 1         2 my $attribute = shift;
268              
269 1         3 $attribute = '_' . $attribute;
270            
271             # Make a hash of allowed attributes.
272 1         3 my %valid = map { $_ => undef } qw( _country _currency _language );
  3         7  
273              
274 1 50       4 croak "ERROR: No attribute specified to empty." unless $attribute;
275 1 50       3 croak qq{ERROR: Invalid attribute ("$attribute") specified to be emptied.} unless exists $valid{$attribute};
276              
277 1         2 delete $self->{$attribute};
278            
279 1         2 $self;
280             }
281              
282             # Small methods that set or get object attributes.
283             # Could do with being refactored into an AUTOLOAD.
284              
285             sub country_code_alpha2
286             {
287 2     2 1 3 my $self = shift;
288              
289 2 50       5 croak "No value given for country_code_alpha2" unless @_;
290              
291 2         11 $self->{_country} = Locale::Object::Country->new( code_alpha2 => shift );
292             }
293              
294             sub country_code_alpha3
295             {
296 1     1 1 2 my $self = shift;
297            
298 1 50       5 croak "No value given for country_code_alpha3" unless @_;
299              
300 1         5 $self->{_country} = Locale::Object::Country->new( code_alpha3 => shift );
301             }
302              
303             sub country_code_numeric
304             {
305 1     1 0 3 my $self = shift;
306            
307 1 50       4 croak "No value given for country_code_numeric" unless @_;
308              
309 1         6 $self->{_country} = Locale::Object::Country->new( code_numeric => shift );
310             }
311              
312             sub country_name
313             {
314 4     4 0 8 my $self = shift;
315              
316 4 50       12 croak "No value given for country_name" unless @_;
317            
318 4         15 $self->{_country} = Locale::Object::Country->new( name => shift );
319             }
320              
321             sub currency_code
322             {
323 7     7 0 13 my $self = shift;
324            
325 7 50       15 croak 'No value given for currency_code' unless @_;
326              
327 7         25 $self->{_currency} = Locale::Object::Currency->new( code => shift );
328             }
329              
330             sub currency_code_numeric
331             {
332 1     1 1 3 my $self = shift;
333            
334 1 50       4 croak 'No value given for currency_code_numeric' unless @_;
335              
336 1         3 $self->{_currency} = Locale::Object::Currency->new( code_numeric => shift );
337             }
338              
339             sub language_code_alpha2
340             {
341 4     4 1 7 my $self = shift;
342            
343 4 50       12 croak 'No value given for language_code' unless @_;
344              
345 4         18 $self->{_language} = Locale::Object::Language->new( code_alpha2 => shift );
346             }
347              
348             sub language_code_alpha3
349             {
350 1     1 1 3 my $self = shift;
351            
352 1 50       4 croak 'No value given for language_code_alpha3' unless @_;
353              
354 1         6 $self->{_language} = Locale::Object::Language->new( code_alpha3 => shift );
355             }
356              
357             sub language_name
358             {
359 5     5 1 10 my $self = shift;
360            
361 5 50       14 croak 'No value given for language_name' unless @_;
362              
363 5         14 $self->{_language} = Locale::Object::Language->new( name => shift );
364             }
365              
366             sub language
367             {
368 0     0 1   my $self = shift;
369            
370 0           return $self->{_language};
371             }
372              
373             sub country
374             {
375 0     0 1   my $self = shift;
376            
377 0           return $self->{_country};
378             }
379              
380             sub currency
381             {
382 0     0 1   my $self = shift;
383            
384 0           return $self->{_currency};
385             }
386              
387             1;
388              
389             __END__
390              
391             =head1 NAME
392              
393             Locale::Object - An object-oriented representation of locale information.
394              
395             =head1 DESCRIPTION
396              
397             The C<Locale::Object> group of modules attempts to provide locale-related information in an object-oriented fashion. The information is collated from several sources and provided in an accompanying L<DBD::SQLite> database.
398              
399             At present, the modules are:
400              
401             =over 4
402              
403             =item * L<Locale::Object> - make compound objects containing country, currency and language objects
404              
405             =item * L<Locale::Object::Country> - objects representing countries
406              
407             =item * L<Locale::Object::Continent> - objects representing continents
408              
409             =item * L<Locale::Object::Currency> - objects representing currencies
410              
411             =item * L<Locale::Object::Currency::Converter> - convert between currencies
412              
413             =item * L<Locale::Object::DB> - does lookups for the modules in the database
414              
415             =item * L<Locale::Object::Language> - objects representing languages
416              
417             =back
418              
419             For more information, see the documentation for those modules. The database is documented in L<Locale::Object::Database>. Locale::Object itself can be used to create compound objects containing country, currency and language objects.
420              
421             =head1 SYNOPSIS
422              
423             use Locale::Object;
424            
425             my $obj = Locale::Object->new(
426             country_code_alpha2 => 'gb',
427             currency_code => 'GBP',
428             language_code_alpha2 => 'en'
429             );
430              
431             $obj->country_code_alpha2('af');
432             $obj->country_code_alpha3('afg');
433              
434             $obj->currency_code('AFA');
435             $obj->currency_code_numeric('004');
436            
437             $obj->language_code_alpha2('ps');
438             $obj->language_code_alpha3('pus');
439             $obj->language_name('Pushto');
440            
441             my $country = $obj->country;
442             my $currency = $obj->currency;
443             my $language = $obj->language;
444            
445             $obj->empty('language');
446            
447             print $obj->sane('country');
448              
449             $obj->make_sane(
450             attribute => 'country'
451             populate => 1
452             );
453            
454             =head1 METHODS
455              
456             =head2 C<new()>
457              
458             my $obj = Locale::Object->new(
459             country_code_alpha2 => 'gb',
460             currency_code => 'GBP',
461             language_code_alpha2 => 'en'
462             );
463              
464             Creates a new object. With no parameters, the object will be blank. Valid parameters match the method names that follow.
465              
466             =head2 C<country_code_alpha2(), country_code_alpha3()>
467              
468             $obj->country_code_alpha2('af');
469             $obj->country_code_alpha3('afg');
470              
471             Sets the country attribute in the object by alpha2 and alpha3 codes. Will create a new L<Locale::Object::Country> object and set that as the attribute. Because Locale::Object::Country objects all have single instances, if one has already been created by that code, it will be reused when you do this.
472            
473             =head2 C<country_code(), currency_code_numeric()>
474              
475             $obj->currency_code('AFA');
476             $obj->currency_code_numeric('004');
477              
478             Serves the same purpose as the previous methods, only for the currency attribute, a L<Locale::Object::Currency> object.
479              
480             =head2 C<language_code_alpha2(), language_code_alpha3(), language_name()>
481              
482             $obj->language_code_alpha2('ps');
483             $obj->language_code_alpha3('pus');
484             $obj->language_name('Pushto');
485              
486             Serves the same purpose as the previous methods, only for the language attribute, a L<Locale::Object::Language> object.
487              
488             =head1 Retrieving and Removing Attributes
489              
490             =head2 C<country(), language(), currency()>
491              
492             While the foregoing methods can be used to set attribute objects, to retrieve those objects' own attributes you will have to use their own methods. The C<country()>, C<language()> and C<currency()> methods return the objects stored as those attributes, if they exist.
493              
494             my $country_tzone = $country->timezone->name;
495             my $language_name = $obj->language->name;
496             my $currency_code = $obj->currency->code;
497            
498             See L<Locale::Object::Country>, L<Locale::Object::Language> and L<Locale::Object::Currency> for more details on the subordinate methods.
499              
500             =head2 C<empty()>
501              
502             $obj->empty('language');
503              
504             Remove an attribute from the object. Can be one of C<country>, C<currency>, C<language>.
505              
506             =head1 Object Sanity
507              
508             =head2 C<sane()>
509              
510             There will be occasions you want to know whether all the attributes in your object make sense with each other - questions such as "is the currency of the object used in the country?" or "Do they speak the language of the object in that country?" For that, use C<sane()>.
511              
512             print $obj->sane('country');
513            
514             Returns 1 if the two remaining attributes in the object make sense compared against the attribute name you specify (if not specified, country is the default); otherwise, 0. The following table explains what's needed for a result of 1. Note: if an attribute doesn't exist, it's not *not* sane, so checking sanity against an attribute in an object with no other attributes will give a result of 1.
515              
516             If sane against | country must | language must | currency must
517             -----------------------------------------------------------------------------------------
518             country | n/a | be used in the country | be used in the country
519             -----------------------------------------------------------------------------------------
520             language | be using the language | n/a | be used in a country
521             | | | speaking the language
522             -----------------------------------------------------------------------------------------
523             currency | use the currency | be spoken in a country | n/a
524             | | using the currency |
525            
526             =head2 C<make_sane()>
527              
528             $obj->make_sane(
529             attribute => 'country'
530             populate => 1
531             );
532            
533             This method will do its best to make the attributes of the object correspond with each other. The attribute you specify as a parameter will be taken to align against (default is country if none specified). If you specify C<populate> as 1, any empty attributes in the object will be filled. Provisos:
534              
535             =over 4
536              
537             =item 1) Languages can be used in multiple countries. If you C<make_sane> against language, to pick a country the module will choose the first country it finds that uses the language officially.
538              
539             =item 2) A similar situation exists for currencies. If a language attribute already exists, the module will pick the first country it finds that speaks the language and uses the currency. Otherwise, it will select the first country in its list of countries using the currency.
540              
541             =back
542              
543             =head1 AUTHOR
544              
545             Originally by Earle Martin
546              
547             =head1 COPYRIGHT AND LICENSE
548              
549             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/>.
550              
551             =head1 SEE ALSO
552              
553             L<Locale::Codes>, for simple conversions between names and ISO codes.
554              
555             =cut