File: | blib/lib/CGI/Lingua.pm |
Coverage: | 57.8% |
line | stmt | bran | cond | sub | time | code |
---|---|---|---|---|---|---|
1 | package CGI::Lingua; | |||||
2 | ||||||
3 | 19 19 19 | 1258259 15 437 | use warnings; | |||
4 | 19 19 19 | 31 14 207 | use strict; | |||
5 | ||||||
6 | 19 19 19 | 3408 816742 299 | use Object::Configure 0.14; | |||
7 | 19 19 19 | 50 95 275 | use Params::Get 0.13; | |||
8 | 19 19 19 | 30 12 411 | use Storable; # RT117983 | |||
9 | 19 19 19 | 4362 59080 71 | use Class::Autouse qw{Carp Locale::Language Locale::Object::Country Locale::Object::DB I18N::AcceptLanguage I18N::LangTags::Detect}; | |||
10 | ||||||
11 | our $VERSION = '0.77'; | |||||
12 | ||||||
13 - 21 | =head1 NAME CGI::Lingua - Create a multilingual web page =head1 VERSION Version 0.77 =cut | |||||
22 | ||||||
23 - 157 | =head1 SYNOPSIS CGI::Lingua is a powerful module for multilingual web applications offering extensive language/country detection strategies. No longer does your website need to be in English only. CGI::Lingua provides a simple basis to determine which language to display a website. The website tells CGI::Lingua which languages it supports. Based on that list CGI::Lingua tells the application which language the user would like to use. use CGI::Lingua; # ... my $l = CGI::Lingua->new(['en', 'fr', 'en-gb', 'en-us']); my $language = $l->language(); if ($language eq 'English') { print '<P>Hello</P>'; } elsif($language eq 'French') { print '<P>Bonjour</P>'; } else { # $language eq 'Unknown' my $rl = $l->requested_language(); print "<P>Sorry for now this page is not available in $rl.</P>"; } my $c = $l->country(); if ($c eq 'us') { # print contact details in the US } elsif ($c eq 'ca') { # print contact details in Canada } else { # print worldwide contact details } # ... use CHI; use CGI::Lingua; # ... my $cache = CHI->new(driver => 'File', root_dir => '/tmp/cache', namespace => 'CGI::Lingua-countries'); $l = CGI::Lingua->new({ supported => ['en', 'fr'], cache => $cache }); =head1 SUBROUTINES/METHODS =head2 new Creates a CGI::Lingua object. Takes one mandatory parameter, C<supported>, a list of languages, in RFC-1766 format, that the website supports. Language codes are of the form primary-code [ - country-code ] e.g. 'en', 'en-gb' for English and British English respectively. For a list of primary codes refer to ISO-639 (e.g. 'en' for English). For a list of country codes refer to ISO-3166 (e.g. 'gb' for United Kingdom). # Sample web page use CGI::Lingua; use CHI; use Log::Abstraction; my $cache = CHI->new(driver => 'File', root_dir => '/tmp/cache'); # We support English, French, British and American English, in that order my $lingua = CGI::Lingua->new( supported => ['en', 'fr', 'en-gb', 'en-us'], cache => $cache, logger => Log::Abstraction->new() ); print "Content-Type: text/plain\n\n"; print 'Language: ', $lingua->language(), "\n"; print 'Country: ', $lingua->country(), "\n"; print 'Time Zone: ', $lingua->time_zone(), "\n"; Supported_languages is the same as supported. It takes several optional parameters: =over 4 =item * C<cache> An object which is used to cache country lookups. This cache object is an object that understands get() and set() messages, such as a L<CHI> object. =item * C<config_file> Points to a configuration file which contains the parameters to C<new()>. The file can be in any common format, including C<YAML>, C<XML>, and C<INI>. This allows the parameters to be set at run time. =item * C<logger> Used for warnings and traces. It can be an object that understands warn() and trace() messages, such as a L<Log::Abstraction>, L<Log::Log4perl> or L<Log::Any> object, a reference to code, a reference to an array, or a filename. See L<Log::Abstraction> for further details. =item * C<info> Takes an optional parameter info, an object which can be used to see if a CGI parameter is set, for example, an L<CGI::Info> object. =item * C<data> Passed on to L<I18N::AcceptLanguage>. =item * C<dont_use_ip> By default, if none of the requested languages is supported, CGI::Lingua->language() looks in the IP address for the language to use. This may not be what you want, so use this option to disable the feature. =item * C<syslog> Takes an optional parameter syslog, to log messages to L<Sys::Syslog>. It can be a boolean to enable/disable logging to syslog, or a reference to a hash to be given to Sys::Syslog::setlogsock. =back Since emitting warnings from a CGI class can result in messages being lost (you may forget to look in your server's log), or appear to the client in amongst HTML causing invalid HTML, it is recommended either syslog or logger (or both) are set. If neither is given, L<Carp> will be used. =cut | |||||
158 | ||||||
159 | sub new | |||||
160 | { | |||||
161 | 50 | 2067627 | my $class = shift; | |||
162 | 50 | 113 | my $params = Params::Get::get_params('supported', @_); | |||
163 | ||||||
164 | 48 | 992 | if(!defined($class)) { | |||
165 | 1 | 2 | if($params) { | |||
166 | # Using CGI::Lingua:new(), not CGI::Lingua->new() | |||||
167 | 1 | 2 | if(my $logger = $params->{'logger'}) { | |||
168 | 0 | 0 | $logger->error(__PACKAGE__, ' use ->new() not ::new() to instantiate'); | |||
169 | } | |||||
170 | 1 | 7 | Carp::croak(__PACKAGE__, ' use ->new() not ::new() to instantiate'); | |||
171 | } | |||||
172 | ||||||
173 | # FIXME: this only works when no arguments are given | |||||
174 | 0 | 0 | $class = __PACKAGE__; | |||
175 | } elsif(ref($class)) { | |||||
176 | # clone the given object | |||||
177 | 1 | 3 | $params->{_supported} ||= $params->{supported} if(defined($params->{'supported'})); | |||
178 | 1 1 1 | 1 2 3 | return bless { %{$class}, %{$params} }, ref($class); | |||
179 | } | |||||
180 | ||||||
181 | 46 | 97 | $params = Object::Configure::configure($class, $params); | |||
182 | ||||||
183 | # Validate logger object has required methods | |||||
184 | 46 | 358869 | if(defined $params->{'logger'}) { | |||
185 | 46 | 199 | unless(Scalar::Util::blessed($params->{'logger'}) && $params->{'logger'}->can('warn') && $params->{'logger'}->can('info') && $params->{'logger'}->can('error')) { | |||
186 | 0 | 0 | Carp::croak("Logger must be an object with info() and error() methods"); | |||
187 | } | |||||
188 | } | |||||
189 | ||||||
190 | # TODO: check that the number of supported languages is > 0 | |||||
191 | # unless($params->{supported} && ($#params->{supported} > 0)) { | |||||
192 | # croak('You must give a list of supported languages'); | |||||
193 | # } | |||||
194 | 46 | 1507 | $params->{'supported'} ||= $params->{'supported_languages'}; | |||
195 | 46 | 56 | unless($params->{supported}) { | |||
196 | 2 | 3 | if(my $logger = $params->{'logger'}) { | |||
197 | 2 | 3 | $logger->error('You must give a list of supported languages'); | |||
198 | } | |||||
199 | 2 | 515 | Carp::croak('You must give a list of supported languages'); | |||
200 | } | |||||
201 | ||||||
202 | 45 | 339 | my $cache = $params->{cache}; | |||
203 | 45 | 36 | my $info = $params->{info}; | |||
204 | ||||||
205 | 45 | 62 | if($cache && $ENV{'REMOTE_ADDR'}) { | |||
206 | 7 | 7 | my $key = "$ENV{REMOTE_ADDR}/"; | |||
207 | 7 | 7 | my $l; | |||
208 | 7 | 18 | if($info && ($l = $info->lang())) { | |||
209 | 0 | 0 | $key .= "$l/"; | |||
210 | } elsif($l = $class->_what_language()) { | |||||
211 | 7 | 6 | $key .= "$l/"; | |||
212 | } | |||||
213 | 7 7 | 9 11 | $key .= join('/', @{$params->{supported}}); | |||
214 | # if($logger) { | |||||
215 | # $self->debug("Looking in cache for $key"); | |||||
216 | # } | |||||
217 | 7 | 15 | if(my $rc = $cache->get($key)) { | |||
218 | # if($logger) { | |||||
219 | # $logger->debug('Found - thawing'); | |||||
220 | # } | |||||
221 | 0 | 0 | $rc = Storable::thaw($rc); | |||
222 | 0 | 0 | $rc->{logger} = $params->{'logger'}; | |||
223 | 0 | 0 | $rc->{_syslog} = $params->{syslog}; | |||
224 | 0 | 0 | $rc->{_cache} = $cache; | |||
225 | 0 | 0 | $rc->{_supported} = $params->{supported}; | |||
226 | 0 | 0 | $rc->{_info} = $info; | |||
227 | 0 | 0 | $rc->{_have_ipcountry} = -1; | |||
228 | 0 | 0 | $rc->{_have_geoip} = -1; | |||
229 | 0 | 0 | $rc->{_have_geoipfree} = -1; | |||
230 | ||||||
231 | 0 | 0 | if(($rc->{_what_language} || $rc->{_rlanguage}) && $info && $info->lang()) { | |||
232 | 0 | 0 | delete $rc->{_what_language}; | |||
233 | 0 | 0 | delete $rc->{_rlanguage}; | |||
234 | 0 | 0 | delete $rc->{_country}; | |||
235 | } | |||||
236 | 0 | 0 | return $rc; | |||
237 | } | |||||
238 | } | |||||
239 | ||||||
240 | return bless { | |||||
241 | 45 | 359 | %{$params}, | |||
242 | _supported => $params->{supported}, # List of languages (two letters) that the application | |||||
243 | _cache => $cache, # CHI | |||||
244 | _info => $info, | |||||
245 | # _rlanguage => undef, # Requested language | |||||
246 | # _slanguage => undef, # Language that the website should display | |||||
247 | # _sublanguage => undef, # E.g. United States for en-US if you want American English | |||||
248 | # _slanguage_code_alpha2 => undef, # E.g en, fr | |||||
249 | # _sublanguage_code_alpha2 => undef, # E.g. us, gb | |||||
250 | # _country => undef, # Two letters, e.g. gb | |||||
251 | # _locale => undef, # Locale::Object::Country | |||||
252 | _syslog => $params->{syslog}, | |||||
253 | _dont_use_ip => $params->{dont_use_ip} || 0, | |||||
254 | _have_ipcountry => -1, # -1 = don't know | |||||
255 | _have_geoip => -1, # -1 = don't know | |||||
256 | _have_geoipfree => -1, # -1 = don't know | |||||
257 | 45 | 371 | _debug => $params->{debug} || 0, | |||
258 | }, $class; | |||||
259 | } | |||||
260 | ||||||
261 | # Some of the information takes a long time to work out, so cache what we can | |||||
262 | sub DESTROY { | |||||
263 | 53 | 19865 | if(defined($^V) && ($^V ge 'v5.14.0')) { | |||
264 | 53 | 83 | return if ${^GLOBAL_PHASE} eq 'DESTRUCT'; # >= 5.14.0 only | |||
265 | } | |||||
266 | 53 | 109 | unless($ENV{'REMOTE_ADDR'}) { | |||
267 | 17 | 52 | return; | |||
268 | } | |||||
269 | 36 | 34 | my $self = shift; | |||
270 | 36 | 39 | return unless(ref($self)); | |||
271 | ||||||
272 | 36 | 34 | my $cache = $self->{_cache}; | |||
273 | 36 | 126 | return unless($cache); | |||
274 | ||||||
275 | 7 | 7 | my $key = "$ENV{REMOTE_ADDR}/"; | |||
276 | 7 | 8 | if(my $l = $self->_what_language()) { | |||
277 | 7 | 7 | $key .= "$l/"; | |||
278 | } | |||||
279 | 7 7 | 4 14 | $key .= join('/', @{$self->{_supported}}); | |||
280 | 7 | 7 | return if($cache->get($key)); | |||
281 | ||||||
282 | 7 | 271 | $self->_debug("Storing self in cache as $key"); | |||
283 | ||||||
284 | my $copy = bless { | |||||
285 | _slanguage => $self->{_slanguage}, | |||||
286 | _slanguage_code_alpha2 => $self->{_slanguage_code_alpha2}, | |||||
287 | _sublanguage_code_alpha2 => $self->{_sublanguage_code_alpha2}, | |||||
288 | _country => $self->{_country}, | |||||
289 | _rlanguage => $self->{_rlanguage}, | |||||
290 | _dont_use_ip => $self->{_dont_use_ip}, | |||||
291 | _have_ipcountry => $self->{_have_ipcountry}, | |||||
292 | _have_geoip => $self->{_have_geoip}, | |||||
293 | _have_geoipfree => $self->{_have_geoipfree}, | |||||
294 | 7 | 109 | }, ref($self); | |||
295 | ||||||
296 | # All of these crash, presumably something recursive is going on | |||||
297 | # my $copy = Clone::clone($self); | |||||
298 | # my $storable = Storable::nfreeze(Storable::dclone($self)); | |||||
299 | # my $storable = Storable::dclone($self); | |||||
300 | ||||||
301 | 7 | 13 | $cache->set($key, Storable::nfreeze($copy), '1 month'); | |||
302 | } | |||||
303 | ||||||
304 | ||||||
305 - 330 | =head2 language Tells the CGI application in what language to display its messages. The language is the natural name e.g. 'English' or 'Japanese'. Sublanguages are handled sensibly, so that if a client requests U.S. English on a site that only serves British English, language() will return 'English'. If none of the requested languages is included within the supported lists, language() returns 'Unknown'. use CGI::Lingua; # Site supports English and British English my $l = CGI::Lingua->new(supported => ['en', 'fr', 'en-gb']); If the browser requests 'en-us', then language will be 'English' and sublanguage will also be undefined, which may seem strange, but it ensures that sites behave sensibly. # Site supports British English only my $l = CGI::Lingua->new({ supported => ['fr', 'en-gb']} ); If the script is not being run in a CGI environment, perhaps to debug it, the locale is used via the LANG environment variable. =cut | |||||
331 | ||||||
332 | sub language { | |||||
333 | 24 | 3054 | my $self = shift; | |||
334 | ||||||
335 | 24 | 41 | unless($self->{_slanguage}) { | |||
336 | 16 | 25 | $self->_find_language(); | |||
337 | } | |||||
338 | 24 | 61 | return $self->{_slanguage}; | |||
339 | } | |||||
340 | ||||||
341 - 345 | =head2 preferred_language Same as language(). =cut | |||||
346 | ||||||
347 | sub preferred_language | |||||
348 | { | |||||
349 | 1 | 2 | my $self = shift; | |||
350 | ||||||
351 | 1 | 2 | $self->language(@_); | |||
352 | } | |||||
353 | ||||||
354 - 358 | =head2 name Synonym for language, for compatibility with Local::Object::Language =cut | |||||
359 | ||||||
360 | sub name { | |||||
361 | 1 | 1 | my $self = shift; | |||
362 | ||||||
363 | 1 | 2 | return $self->language(); | |||
364 | } | |||||
365 | ||||||
366 - 374 | =head2 sublanguage Tells the CGI what variant to use e.g. 'United Kingdom', or 'Unknown' if it can't be determined. Sublanguages are handled sensibly, so that if a client requests U.S. English on a site that only serves British English, sublanguage() will return undef. =cut | |||||
375 | ||||||
376 | sub sublanguage { | |||||
377 | 21 | 25 | my $self = shift; | |||
378 | ||||||
379 | 21 | 27 | $self->_trace('Entered sublanguage'); | |||
380 | 21 | 350 | unless($self->{_slanguage}) { | |||
381 | 1 | 2 | $self->_find_language(); | |||
382 | } | |||||
383 | 21 | 45 | $self->_trace('Leaving sublanguage ', ($self->{_sublanguage} || 'undef')); | |||
384 | 21 | 304 | return $self->{_sublanguage}; | |||
385 | } | |||||
386 | ||||||
387 - 395 | =head2 language_code_alpha2 Gives the two-character representation of the supported language, e.g. 'en' when you've asked for en-gb. If none of the requested languages is included within the supported lists, language_code_alpha2() returns undef. =cut | |||||
396 | ||||||
397 | sub language_code_alpha2 { | |||||
398 | 8 | 6 | my $self = shift; | |||
399 | ||||||
400 | 8 | 10 | $self->_trace('Entered language_code_alpha2'); | |||
401 | 8 | 141 | unless($self->{_slanguage}) { | |||
402 | 1 | 6 | $self->_find_language(); | |||
403 | } | |||||
404 | 8 | 14 | $self->_trace('language_code_alpha2 returns ', $self->{_slanguage_code_alpha2}); | |||
405 | 8 | 118 | return $self->{_slanguage_code_alpha2}; | |||
406 | } | |||||
407 | ||||||
408 - 412 | =head2 code_alpha2 Synonym for language_code_alpha2, kept for historical reasons. =cut | |||||
413 | ||||||
414 | sub code_alpha2 { | |||||
415 | 8 | 492 | my $self = shift; | |||
416 | ||||||
417 | 8 | 12 | return $self->language_code_alpha2(); | |||
418 | } | |||||
419 | ||||||
420 - 425 | =head2 sublanguage_code_alpha2 Gives the two-character representation of the supported language, e.g. 'gb' when you've asked for en-gb, or undef. =cut | |||||
426 | ||||||
427 | sub sublanguage_code_alpha2 { | |||||
428 | 2 | 8 | my $self = shift; | |||
429 | ||||||
430 | 2 | 7 | unless($self->{_slanguage}) { | |||
431 | 1 | 3 | $self->_find_language(); | |||
432 | } | |||||
433 | 2 | 8 | return $self->{_sublanguage_code_alpha2}; | |||
434 | } | |||||
435 | ||||||
436 | ||||||
437 - 445 | =head2 requested_language Gives a human-readable rendition of what language the user asked for whether or not it is supported. Returns the sublanguage (if appropriate) in parentheses, e.g. "English (United Kingdom)" =cut | |||||
446 | ||||||
447 | sub requested_language { | |||||
448 | 44 | 7983 | my $self = shift; | |||
449 | ||||||
450 | 44 | 62 | unless($self->{_rlanguage}) { | |||
451 | 10 | 14 | $self->_find_language(); | |||
452 | } | |||||
453 | 44 | 94 | return $self->{_rlanguage}; | |||
454 | } | |||||
455 | ||||||
456 | # The language cache is stored as country_2_letter -> $language_human_readable_name=$language_2_letter | |||||
457 | # The IP cache is stored as ip -> country_human_readable_name | |||||
458 | ||||||
459 | # Returns the human-readable language, such as 'English' | |||||
460 | ||||||
461 | sub _find_language | |||||
462 | { | |||||
463 | 29 | 21 | my $self = shift; | |||
464 | ||||||
465 | 29 | 40 | $self->_trace('Entered _find_language'); | |||
466 | ||||||
467 | # Initialize defaults | |||||
468 | 29 | 496 | $self->{_rlanguage} = 'Unknown'; | |||
469 | 29 | 39 | $self->{_slanguage} = 'Unknown'; | |||
470 | ||||||
471 | # Use what the client has said | |||||
472 | 29 | 40 | my $http_accept_language = $self->_what_language(); | |||
473 | 29 | 34 | if(defined($http_accept_language)) { | |||
474 | 29 29 | 31 63 | $self->_debug("language wanted: $http_accept_language, languages supported: ", join(', ', @{$self->{_supported}})); | |||
475 | ||||||
476 | 29 | 391 | if($http_accept_language eq 'en-uk') { | |||
477 | 0 | 0 | $self->_debug("Resetting country code to GB for $http_accept_language"); | |||
478 | 0 | 0 | $http_accept_language = 'en-gb'; | |||
479 | } | |||||
480 | # Workaround for RT 74338 | |||||
481 | local $SIG{__WARN__} = sub { | |||||
482 | 0 | 0 | if($_[0] !~ /^Use of uninitialized value/) { | |||
483 | 0 | 0 | warn $_[0]; | |||
484 | } | |||||
485 | 29 | 87 | }; | |||
486 | 29 | 123 | my $i18n = I18N::AcceptLanguage->new(debug => $self->{_debug}, strict => 1); | |||
487 | 29 | 7075 | my $l = $i18n->accepts($http_accept_language, $self->{_supported}); | |||
488 | 29 | 2240 | local $SIG{__WARN__} = 'DEFAULT'; | |||
489 | 29 | 237 | if($l && ($http_accept_language =~ /-/) && ($http_accept_language !~ qr/$l/i)) { | |||
490 | # I18N-AcceptLanguage strict mode doesn't work as I'd expect it to, | |||||
491 | # if you support 'en' and 'en-gb' and request 'en-US,en;q=0.8', | |||||
492 | # it actually returns 'en-gb' | |||||
493 | 3 | 17 | $self->_debug('Forcing fallback'); | |||
494 | 3 | 80 | undef $l; | |||
495 | } | |||||
496 | ||||||
497 | 29 | 31 | my $requested_sublanguage; | |||
498 | 29 | 35 | if(!$l) { | |||
499 | # FIXME: This scans the HTTP_ACCEPTED_LANGUAGE left to right, it ignores the priority value | |||||
500 | 8 | 17 | $self->_debug(__PACKAGE__, ': ', __LINE__, ": look through $http_accept_language for alternatives"); | |||
501 | 8 | 127 | while($http_accept_language =~ /(..)\-(..)/g) { | |||
502 | 7 | 46 | $requested_sublanguage = $2; | |||
503 | # Fall back position, e,g. we want US English on a site | |||||
504 | # only giving British English, so allow it as English. | |||||
505 | # The calling program can detect that it's not the | |||||
506 | # wanted flavour of English by looking at | |||||
507 | # requested_language | |||||
508 | 7 | 17 | $self->_debug(__PACKAGE__, ': ', __LINE__, ": see if $1 is supported"); | |||
509 | 7 | 91 | if($i18n->accepts($1, $self->{_supported})) { | |||
510 | 4 | 188 | $l = $1; | |||
511 | 4 | 8 | $self->_debug("Fallback to $l as sublanguage $requested_sublanguage is not supported"); | |||
512 | 4 | 47 | last; | |||
513 | } | |||||
514 | } | |||||
515 | } | |||||
516 | 29 | 110 | if(!$l) { | |||
517 | # FIXME: This scans the HTTP_ACCEPTED_LANGUAGE left to right, it ignores the priority value | |||||
518 | 4 | 7 | $self->_debug(__PACKAGE__, ': ', __LINE__, ": look harder through $http_accept_language for alternatives"); | |||
519 | 4 | 59 | foreach my $possible(split(/,/, $http_accept_language)) { | |||
520 | 6 | 40 | next if($possible =~ /..\-../); # Already checked those with sublanguages | |||
521 | 4 | 6 | $possible =~ s/;.*$//; | |||
522 | 4 | 8 | $self->_debug(__PACKAGE__, ': ', __LINE__, ": see if $possible is supported"); | |||
523 | 4 | 56 | if($i18n->accepts($possible, $self->{_supported})) { | |||
524 | 1 | 25 | $l = $possible; | |||
525 | 1 | 2 | $self->_debug("Fallback to $possible as best alternative"); | |||
526 | 1 | 12 | undef $requested_sublanguage; | |||
527 | 1 | 1 | last; | |||
528 | } | |||||
529 | } | |||||
530 | } | |||||
531 | ||||||
532 | 29 | 134 | if($l) { | |||
533 | 26 | 44 | $self->_debug("l: $l"); | |||
534 | ||||||
535 | 26 | 427 | if($l !~ /^..-..$/) { | |||
536 | 11 | 18 | $self->{_slanguage} = $self->_code2language($l); | |||
537 | 11 | 363682 | if($self->{_slanguage}) { | |||
538 | 11 | 24 | $self->_debug("_slanguage: $self->{_slanguage}"); | |||
539 | ||||||
540 | # We have the language, but not the right | |||||
541 | # sublanguage, e.g. they want US English but we | |||||
542 | # only support British English or English | |||||
543 | # wanted: en-us, got en-gb and en | |||||
544 | 11 | 193 | $self->{_slanguage_code_alpha2} = $l; | |||
545 | 11 | 13 | $self->{_rlanguage} = $self->{_slanguage}; | |||
546 | ||||||
547 | 11 | 6 | my $sl; | |||
548 | 11 | 61 | if($http_accept_language =~ /..-(..)$/) { | |||
549 | 3 | 3 | $self->_debug($1); | |||
550 | 3 | 43 | $sl = $self->_code2country($1); | |||
551 | 3 | 6 | $requested_sublanguage = $1 if(!defined($requested_sublanguage)); | |||
552 | } elsif($http_accept_language =~ /..-([a-z]{2,3})$/i) { | |||||
553 | 0 | 0 | $sl = Locale::Object::Country->new(code_alpha3 => $1); | |||
554 | } | |||||
555 | 11 | 43 | if($sl) { | |||
556 | 3 | 7 | $self->{_rlanguage} .= ' (' . $sl->name() . ')'; | |||
557 | # The requested sublanguage | |||||
558 | # isn't supported so don't | |||||
559 | # define that | |||||
560 | } elsif($requested_sublanguage) { | |||||
561 | 2 | 4 | if(my $c = $self->_code2countryname($requested_sublanguage)) { | |||
562 | 2 | 11 | $self->{_rlanguage} .= " ($c)"; | |||
563 | } else { | |||||
564 | 0 | 0 | $self->{_rlanguage} .= " (Unknown: $requested_sublanguage)"; | |||
565 | } | |||||
566 | } | |||||
567 | 11 | 95 | return; | |||
568 | } | |||||
569 | } elsif($l =~ /(.+)-(..)$/) { # TODO: Handle es-419 "Spanish (Latin America)" | |||||
570 | 15 | 17 | my $alpha2 = $1; | |||
571 | 15 | 14 | my $variety = $2; | |||
572 | 15 | 23 | my $accepts = $i18n->accepts($l, $self->{_supported}); | |||
573 | 15 | 1001 | $self->_debug("accepts = $accepts"); | |||
574 | ||||||
575 | 15 | 201 | if($accepts) { | |||
576 | 15 | 25 | $self->_debug("accepts: $accepts"); | |||
577 | ||||||
578 | 15 | 183 | if($accepts =~ /\-/) { | |||
579 | 15 | 19 | delete $self->{_slanguage}; | |||
580 | } else { | |||||
581 | 0 | 0 | my $from_cache; | |||
582 | 0 | 0 | if($self->{_cache}) { | |||
583 | 0 | 0 | $from_cache = $self->{_cache}->get(__PACKAGE__ . ":accepts:$accepts"); | |||
584 | } | |||||
585 | 0 | 0 | if($from_cache) { | |||
586 | 0 | 0 | $self->_debug("$accepts is in cache as $from_cache"); | |||
587 | 0 | 0 | $self->{_slanguage} = (split(/=/, $from_cache))[0]; | |||
588 | } else { | |||||
589 | 0 | 0 | $self->{_slanguage} = $self->_code2language($accepts); | |||
590 | } | |||||
591 | 0 | 0 | if($self->{_slanguage}) { | |||
592 | 0 | 0 | if($variety eq 'uk') { | |||
593 | # ??? | |||||
594 | 0 | 0 | $self->_warn({ | |||
595 | warning => "Resetting country code to GB for $http_accept_language" | |||||
596 | }); | |||||
597 | 0 | 0 | $variety = 'gb'; | |||
598 | } | |||||
599 | 0 | 0 | if(defined(my $c = $self->_code2countryname($variety))) { | |||
600 | 0 | 0 | $self->_debug(__PACKAGE__, ': ', __LINE__, ": setting sublanguage to $c"); | |||
601 | 0 | 0 | $self->{_sublanguage} = $c; | |||
602 | } | |||||
603 | 0 | 0 | $self->{_slanguage_code_alpha2} = $accepts; | |||
604 | 0 | 0 | if($self->{_sublanguage}) { | |||
605 | 0 | 0 | $self->{_rlanguage} = "$self->{_slanguage} ($self->{_sublanguage})"; | |||
606 | 0 | 0 | $self->_debug(__PACKAGE__, ': ', __LINE__, ": _rlanguage: $self->{_rlanguage}"); | |||
607 | } | |||||
608 | 0 | 0 | $self->{_sublanguage_code_alpha2} = $variety; | |||
609 | 0 | 0 | unless($from_cache) { | |||
610 | 0 | 0 | $self->_debug("Set $variety to $self->{_slanguage}=$self->{_slanguage_code_alpha2}"); | |||
611 | 0 | 0 | $self->{_cache}->set(__PACKAGE__ . ":accepts:$variety", "$self->{_slanguage}=$self->{_slanguage_code_alpha2}", '1 month'); | |||
612 | } | |||||
613 | 0 | 0 | return; | |||
614 | } | |||||
615 | } | |||||
616 | } | |||||
617 | 15 | 27 | $self->{_rlanguage} = $self->_code2language($alpha2); | |||
618 | 15 | 362338 | $self->_debug("_rlanguage: $self->{_rlanguage}"); | |||
619 | ||||||
620 | 15 | 263 | if($accepts) { | |||
621 | 15 | 25 | $self->_debug("http_accept_language = $http_accept_language"); | |||
622 | # $http_accept_language =~ /(.{2})-(..)/; | |||||
623 | 15 | 218 | $l =~ /(..)-(..)/; | |||
624 | 15 | 20 | $variety = lc($2); | |||
625 | # Ignore en-029 etc (Caribbean English) | |||||
626 | 15 | 60 | if(($variety =~ /[a-z]{2,3}/) && !defined($self->{_sublanguage})) { | |||
627 | 15 | 48 | $self->_get_closest($alpha2, $alpha2); | |||
628 | 15 | 24 | $self->_debug("Find the country code for $variety"); | |||
629 | ||||||
630 | 15 | 209 | if($variety eq 'uk') { | |||
631 | # ??? | |||||
632 | 0 | 0 | $self->_warn({ | |||
633 | warning => "Resetting country code to GB for $http_accept_language" | |||||
634 | }); | |||||
635 | 0 | 0 | $variety = 'gb'; | |||
636 | } | |||||
637 | 15 | 13 | my $from_cache; | |||
638 | my $language_name; | |||||
639 | 15 | 20 | if($self->{_cache}) { | |||
640 | 4 | 9 | $from_cache = $self->{_cache}->get(__PACKAGE__ . ":variety:$variety"); | |||
641 | } | |||||
642 | 15 | 218 | if(defined($from_cache)) { | |||
643 | 2 | 3 | $self->_debug("$variety is in cache as $from_cache"); | |||
644 | ||||||
645 | 2 | 19 | my $language_code2; | |||
646 | 2 | 3 | ($language_name, $language_code2) = split(/=/, $from_cache); | |||
647 | 2 | 4 | $language_name = $self->_code2countryname($variety); | |||
648 | } else { | |||||
649 | 13 | 60 | my $db = Locale::Object::DB->new(); | |||
650 | 13 13 | 72507 26 | my @results = @{$db->lookup( | |||
651 | table => 'country', | |||||
652 | result_column => 'name', | |||||
653 | search_column => 'code_alpha2', | |||||
654 | value => $variety | |||||
655 | )}; | |||||
656 | 13 | 2058 | if(defined($results[0])) { | |||
657 | 13 | 13 | eval { | |||
658 | 13 | 26 | $language_name = $self->_code2countryname($variety); | |||
659 | }; | |||||
660 | } else { | |||||
661 | 0 | 0 | $self->_debug("Can't find the country code for $variety in Locale::Object::DB"); | |||
662 | } | |||||
663 | } | |||||
664 | 15 | 464 | if($@ || !defined($language_name)) { | |||
665 | 0 | 0 | $self->_warn($@) if($@); | |||
666 | 0 | 0 | $self->_debug(__PACKAGE__, ': ', __LINE__, ': setting sublanguage to Unknown'); | |||
667 | 0 | 0 | $self->{_sublanguage} = 'Unknown'; | |||
668 | 0 | 0 | $self->_warn({ | |||
669 | warning => "Can't determine values for $http_accept_language" | |||||
670 | }); | |||||
671 | } else { | |||||
672 | 15 | 20 | $self->{_sublanguage} = $language_name; | |||
673 | 15 | 25 | $self->_debug('variety name ', $self->{_sublanguage}); | |||
674 | 15 | 219 | if($self->{_cache} && !defined($from_cache)) { | |||
675 | 2 | 6 | $self->_debug("Set $variety to $self->{_slanguage}=$self->{_slanguage_code_alpha2}"); | |||
676 | 2 | 23 | $self->{_cache}->set(__PACKAGE__ . ":variety:$variety", "$self->{_slanguage}=$self->{_slanguage_code_alpha2}", '1 month'); | |||
677 | } | |||||
678 | } | |||||
679 | } | |||||
680 | 15 | 246 | if(defined($self->{_sublanguage})) { | |||
681 | 15 | 26 | $self->{_rlanguage} = "$self->{_slanguage} ($self->{_sublanguage})"; | |||
682 | 15 | 14 | $self->{_sublanguage_code_alpha2} = $variety; | |||
683 | 15 | 103 | return; | |||
684 | } | |||||
685 | } | |||||
686 | } | |||||
687 | } elsif($http_accept_language =~ /;/) { | |||||
688 | # e.g. HTTP_ACCEPT_LANGUAGE=de-DE,de;q=0.9,en-US;q=0.8,en;q=0.7 | |||||
689 | # and we don't support DE at all, but we do accept en-US | |||||
690 | 1 1 | 1 3 | $self->_notice(__PACKAGE__, ': ', __LINE__, ": couldn't honour HTTP_ACCEPT_LANGUAGE=$http_accept_language, supported languages are: ", join(',', @{$self->{supported}})); | |||
691 | } | |||||
692 | 3 | 22 | if($self->{_slanguage} && ($self->{_slanguage} ne 'Unknown')) { | |||
693 | 0 | 0 | if($self->{_rlanguage} eq 'Unknown') { | |||
694 | 0 | 0 | $self->{_rlanguage} = I18N::LangTags::Detect::detect(); | |||
695 | } | |||||
696 | 0 | 0 | if($self->{_rlanguage}) { | |||
697 | 0 | 0 | if($l = $self->_code2language($self->{_rlanguage})) { | |||
698 | 0 | 0 | $self->{_rlanguage} = $l; | |||
699 | # } else { | |||||
700 | # We have the language, but not the right | |||||
701 | # sublanguage, e.g. they want US English but we | |||||
702 | # only support British English | |||||
703 | # wanted: en-us, got en-gb and not en | |||||
704 | } | |||||
705 | 0 | 0 | return; | |||
706 | } | |||||
707 | } | |||||
708 | 3 | 11 | if(((!$self->{_rlanguage}) || ($self->{_rlanguage} eq 'Unknown')) && | |||
709 | ((length($http_accept_language) == 2) || ($http_accept_language =~ /^..-..$/))) { | |||||
710 | 1 | 3 | $self->{_rlanguage} = $self->_code2language($http_accept_language); | |||
711 | ||||||
712 | 1 | 42 | unless($self->{_rlanguage}) { | |||
713 | 1 | 1 | $self->{_rlanguage} = 'Unknown'; | |||
714 | } | |||||
715 | } | |||||
716 | 3 | 12 | $self->{_slanguage} = 'Unknown'; | |||
717 | } | |||||
718 | ||||||
719 | 3 | 4 | if($self->{_dont_use_ip}) { | |||
720 | 0 | 0 | return; | |||
721 | } | |||||
722 | ||||||
723 | # The client hasn't said which to use, so guess from their IP address, | |||||
724 | # or the requested language(s) isn't/aren't supported so use the IP | |||||
725 | # address for an alternative | |||||
726 | 3 | 5 | my $country = $self->country(); | |||
727 | ||||||
728 | 3 | 8 | if((!defined($country)) && (my $c = $self->_what_language())) { | |||
729 | 2 | 5 | if($c =~ /^(..)_(..)/) { | |||
730 | 0 | 0 | $country = $2; # Best guess | |||
731 | } elsif($c =~ /^(..)$/) { | |||||
732 | 1 | 2 | $country = $1; # Wrong, but maybe something will drop out | |||
733 | } | |||||
734 | } | |||||
735 | ||||||
736 | 3 | 4 | if(defined($country)) { | |||
737 | 1 | 2 | $self->_debug("country: $country"); | |||
738 | # Determine the first official language of the country | |||||
739 | ||||||
740 | 1 | 13 | my $from_cache; | |||
741 | 1 | 2 | if($self->{_cache}) { | |||
742 | 0 | 0 | $from_cache = $self->{_cache}->get(__PACKAGE__ . ':language_name:' . $country); | |||
743 | } | |||||
744 | 1 | 1 | my $language_name; | |||
745 | my $language_code2; | |||||
746 | 1 | 2 | if($from_cache) { | |||
747 | 0 | 0 | $self->_debug("$country is in cache as $from_cache"); | |||
748 | 0 | 0 | ($language_name, $language_code2) = split(/=/, $from_cache); | |||
749 | } else { | |||||
750 | 1 | 3 | my $l = $self->_code2country(uc($country)); | |||
751 | 1 | 2 | if($l) { | |||
752 | 0 | 0 | $l = ($l->languages_official)[0]; | |||
753 | 0 | 0 | if(defined($l)) { | |||
754 | 0 | 0 | $language_name = $l->name; | |||
755 | 0 | 0 | $language_code2 = $l->code_alpha2; | |||
756 | 0 | 0 | if($language_name) { | |||
757 | 0 | 0 | $self->_debug("Official language: $language_name"); | |||
758 | } | |||||
759 | } | |||||
760 | } | |||||
761 | } | |||||
762 | 1 | 2 | my $ip = $ENV{'REMOTE_ADDR'}; | |||
763 | 1 | 3 | if($language_name) { | |||
764 | 0 | 0 | if((!defined($self->{_rlanguage})) || ($self->{_rlanguage} eq 'Unknown')) { | |||
765 | 0 | 0 | $self->{_rlanguage} = $language_name; | |||
766 | } | |||||
767 | 0 | 0 | unless((exists($self->{_slanguage})) && ($self->{_slanguage} ne 'Unknown')) { | |||
768 | # Check if the language is one that we support | |||||
769 | # Don't bother with secondary language | |||||
770 | 0 | 0 | my $code; | |||
771 | ||||||
772 | 0 | 0 | if($language_name && $language_code2 && !defined($http_accept_language)) { | |||
773 | # This sort of thing speeds up search engine access a lot | |||||
774 | 0 | 0 | $self->_debug("Fast assign to $language_code2"); | |||
775 | 0 | 0 | $code = $language_code2; | |||
776 | } else { | |||||
777 | 0 | 0 | $self->_debug("Call language2code on $self->{_rlanguage}"); | |||
778 | ||||||
779 | 0 | 0 | $code = Locale::Language::language2code($self->{_rlanguage}); | |||
780 | 0 | 0 | unless($code) { | |||
781 | 0 | 0 | if($http_accept_language && ($http_accept_language ne $self->{_rlanguage})) { | |||
782 | 0 | 0 | $self->_debug("Call language2code on $http_accept_language"); | |||
783 | ||||||
784 | 0 | 0 | $code = Locale::Language::language2code($http_accept_language); | |||
785 | } | |||||
786 | 0 | 0 | unless($code) { | |||
787 | # If the language is Norwegian (Nynorsk) | |||||
788 | # lookup Norwegian | |||||
789 | 0 | 0 | if($self->{_rlanguage} =~ /(.+)\s\(.+/) { | |||
790 | 0 | 0 | if((!defined($http_accept_language)) || ($1 ne $self->{_rlanguage})) { | |||
791 | 0 | 0 | $self->_debug("Call language2code on $1"); | |||
792 | ||||||
793 | 0 | 0 | $code = Locale::Language::language2code($1); | |||
794 | } | |||||
795 | } | |||||
796 | 0 | 0 | unless($code) { | |||
797 | 0 | 0 | $self->_warn({ | |||
798 | warning => "Can't determine code from IP $ip for requested language $self->{_rlanguage}" | |||||
799 | }); | |||||
800 | } | |||||
801 | } | |||||
802 | } | |||||
803 | } | |||||
804 | 0 | 0 | if($code) { | |||
805 | 0 | 0 | $self->_get_closest($code, $language_code2); | |||
806 | 0 | 0 | unless($self->{_slanguage}) { | |||
807 | 0 | 0 | $self->_warn({ | |||
808 | warning => "Couldn't determine closest language for $language_name in $self->{_supported}" | |||||
809 | }); | |||||
810 | } else { | |||||
811 | 0 | 0 | $self->_debug("language set to $self->{_slanguage}, code set to $code"); | |||
812 | } | |||||
813 | } | |||||
814 | } | |||||
815 | 0 | 0 | if(!defined($self->{_slanguage_code_alpha2})) { | |||
816 | 0 | 0 | $self->_debug("Can't determine slanguage_code_alpha2"); | |||
817 | } elsif(!defined($from_cache) && $self->{_cache} && | |||||
818 | defined($self->{_slanguage_code_alpha2})) { | |||||
819 | 0 | 0 | $self->_debug("Set $country to $language_name=$self->{_slanguage_code_alpha2}"); | |||
820 | 0 | 0 | $self->{_cache}->set(__PACKAGE__ . ':language_name:' . $country, "$language_name=$self->{_slanguage_code_alpha2}", '1 month'); | |||
821 | } | |||||
822 | } | |||||
823 | } | |||||
824 | } | |||||
825 | ||||||
826 | # Try our very best to give the right country - if they ask for en-us and | |||||
827 | # we only have en-gb then give it to them | |||||
828 | ||||||
829 | # Old code - more readable | |||||
830 | # sub _get_closest { | |||||
831 | # my ($self, $language_string, $alpha2) = @_; | |||||
832 | # | |||||
833 | # foreach (@{$self->{_supported}}) { | |||||
834 | # my $s; | |||||
835 | # if(/^(.+)-.+/) { | |||||
836 | # $s = $1; | |||||
837 | # } else { | |||||
838 | # $s = $_; | |||||
839 | # } | |||||
840 | # if($language_string eq $s) { | |||||
841 | # $self->{_slanguage} = $self->{_rlanguage}; | |||||
842 | # $self->{_slanguage_code_alpha2} = $alpha2; | |||||
843 | # last; | |||||
844 | # } | |||||
845 | # } | |||||
846 | # } | |||||
847 | ||||||
848 | sub _get_closest | |||||
849 | { | |||||
850 | 15 | 21 | my ($self, $language_string, $alpha2) = @_; | |||
851 | ||||||
852 | # Create a hash mapping base languages to their full language codes | |||||
853 | 15 95 15 | 20 141 37 | my %base_languages = map { /^(.+)-/ ? ($1 => $_) : ($_ => $_) } @{$self->{_supported}}; | |||
854 | ||||||
855 | 15 | 29 | if(exists($base_languages{$language_string})) { | |||
856 | 15 | 29 | $self->{_slanguage} = $self->{_rlanguage}; | |||
857 | 15 | 27 | $self->{_slanguage_code_alpha2} = $alpha2; | |||
858 | } | |||||
859 | } | |||||
860 | ||||||
861 | # What's the language being requested? Can be used in both a class and an object context | |||||
862 | sub _what_language { | |||||
863 | 46 | 56 | my $self = shift; | |||
864 | ||||||
865 | 46 | 52 | if(ref($self)) { | |||
866 | 39 | 44 | $self->_trace('Entered _what_language'); | |||
867 | 39 | 509 | if($self->{_what_language}) { | |||
868 | 8 | 10 | $self->_trace('_what_language: returning cached value: ', $self->{_what_language}); | |||
869 | 8 | 90 | return $self->{_what_language}; # Useful in case something changes the $info hash | |||
870 | } | |||||
871 | 31 | 48 | if(my $info = $self->{_info}) { | |||
872 | 0 | 0 | if(my $rc = $info->lang()) { | |||
873 | # E.g. cgi-bin/script.cgi?lang=de | |||||
874 | 0 | 0 | $self->_trace("_what_language set language to $rc from the lang argument"); | |||
875 | 0 | 0 | return $self->{_what_language} = $rc; | |||
876 | } | |||||
877 | } | |||||
878 | } | |||||
879 | ||||||
880 | 38 | 65 | if(my $rc = $ENV{'HTTP_ACCEPT_LANGUAGE'}) { | |||
881 | 36 | 28 | if(ref($self)) { | |||
882 | 29 | 49 | return $self->{_what_language} = $rc; | |||
883 | } | |||||
884 | 7 | 10 | return $rc; | |||
885 | } | |||||
886 | ||||||
887 | 2 | 5 | if(defined($ENV{'LANG'})) { | |||
888 | # Running the script locally, presumably to debug, so set the language | |||||
889 | # from the Locale | |||||
890 | 0 | 0 | if(ref($self)) { | |||
891 | 0 | 0 | return $self->{_what_language} = $ENV{'LANG'}; | |||
892 | } | |||||
893 | 0 | 0 | return $ENV{'LANG'}; | |||
894 | } | |||||
895 | } | |||||
896 | ||||||
897 - 906 | =head2 country Returns the two-character country code of the remote end in lowercase. If L<IP::Country>, L<Geo::IPfree> or L<Geo::IP> is installed, CGI::Lingua will make use of that, otherwise, it will do a Whois lookup. If you do not have any of those installed I recommend you use the caching capability of CGI::Lingua. =cut | |||||
907 | ||||||
908 | sub country { | |||||
909 | 17 | 909 | my $self = shift; | |||
910 | ||||||
911 | 17 | 25 | $self->_trace(__PACKAGE__, ': Entered country()'); | |||
912 | ||||||
913 | # FIXME: If previous calls to country() return undef, we'll | |||||
914 | # waste time going through again and no doubt returning undef | |||||
915 | # again. | |||||
916 | 17 | 351 | if($self->{_country}) { | |||
917 | 0 | 0 | $self->_trace('quick return: ', $self->{_country}); | |||
918 | 0 | 0 | return $self->{_country}; | |||
919 | } | |||||
920 | ||||||
921 | # mod_geoip | |||||
922 | 17 | 27 | if(defined($ENV{'GEOIP_COUNTRY_CODE'})) { | |||
923 | 0 | 0 | $self->{_country} = lc($ENV{'GEOIP_COUNTRY_CODE'}); | |||
924 | 0 | 0 | return $self->{_country}; | |||
925 | } | |||||
926 | 17 | 37 | if(($ENV{'HTTP_CF_IPCOUNTRY'}) && ($ENV{'HTTP_CF_IPCOUNTRY'} ne 'XX')) { | |||
927 | # Hosted by Cloudfare | |||||
928 | 2 | 2 | $self->{_country} = lc($ENV{'HTTP_CF_IPCOUNTRY'}); | |||
929 | 2 | 7 | return $self->{_country}; | |||
930 | } | |||||
931 | ||||||
932 | 15 | 17 | my $ip = $ENV{'REMOTE_ADDR'}; | |||
933 | ||||||
934 | 15 | 23 | return unless(defined($ip)); | |||
935 | ||||||
936 | 4 | 249 | require Data::Validate::IP; | |||
937 | 4 | 14591 | Data::Validate::IP->import(); | |||
938 | ||||||
939 | 4 | 6 | if(!is_ipv4($ip)) { | |||
940 | 1 | 8 | $self->_debug("$ip isn't IPv4. Is it IPv6?"); | |||
941 | 1 | 10 | if($ip eq '::1') { | |||
942 | # special case that is easy to handle | |||||
943 | 1 | 1 | $ip = '127.0.0.1'; | |||
944 | } elsif(!is_ipv6($ip)) { | |||||
945 | 0 | 0 | $self->_warn({ | |||
946 | warning => "$ip isn't a valid IP address" | |||||
947 | }); | |||||
948 | 0 | 0 | return; | |||
949 | } | |||||
950 | } | |||||
951 | 4 | 78 | if(is_private_ip($ip)) { | |||
952 | 1 | 40 | $self->_debug("Can't determine country from LAN connection $ip"); | |||
953 | 1 | 12 | return; | |||
954 | } | |||||
955 | 3 | 186 | if(is_loopback_ip($ip)) { | |||
956 | 1 | 35 | $self->_debug("Can't determine country from loopback connection $ip"); | |||
957 | 1 | 10 | return; | |||
958 | } | |||||
959 | ||||||
960 | 2 | 101 | if($self->{_cache}) { | |||
961 | 0 | 0 | $self->{_country} = $self->{_cache}->get(__PACKAGE__ . ":country:$ip"); | |||
962 | 0 | 0 | if(defined($self->{_country})) { | |||
963 | 0 | 0 | if($self->{_country} !~ /\D/) { | |||
964 | 0 | 0 | $self->_warn('cache contains a numeric country: ', $self->{_country}); | |||
965 | 0 | 0 | $self->{_cache}->remove($ip); | |||
966 | 0 | 0 | delete $self->{_country}; # Seems to be a number | |||
967 | } else { | |||||
968 | 0 | 0 | $self->_debug("Get $ip from cache = $self->{_country}"); | |||
969 | 0 | 0 | return $self->{_country}; | |||
970 | } | |||||
971 | } | |||||
972 | 0 | 0 | $self->_debug("$ip isn't in the cache"); | |||
973 | } | |||||
974 | ||||||
975 | 2 | 4 | if($self->{_have_ipcountry} == -1) { | |||
976 | 2 2 | 2 139 | if(eval { require IP::Country; }) { | |||
977 | 0 | 0 | IP::Country->import(); | |||
978 | 0 | 0 | $self->{_have_ipcountry} = 1; | |||
979 | 0 | 0 | $self->{_ipcountry} = IP::Country::Fast->new(); | |||
980 | } else { | |||||
981 | 2 | 596 | $self->{_have_ipcountry} = 0; | |||
982 | } | |||||
983 | } | |||||
984 | 2 | 7 | $self->_debug("have_ipcountry $self->{_have_ipcountry}"); | |||
985 | ||||||
986 | 2 | 27 | if($self->{_have_ipcountry}) { | |||
987 | 0 | 0 | $self->{_country} = $self->{_ipcountry}->inet_atocc($ip); | |||
988 | 0 | 0 | if($self->{_country}) { | |||
989 | 0 | 0 | $self->{_country} = lc($self->{_country}); | |||
990 | } elsif(is_ipv4($ip)) { | |||||
991 | # Although it doesn't say so, it looks like IP::Country is IPv4 only | |||||
992 | 0 | 0 | $self->_debug("$ip is not known by IP::Country"); | |||
993 | } | |||||
994 | } | |||||
995 | 2 | 4 | unless(defined($self->{_country})) { | |||
996 | 2 | 3 | if($self->{_have_geoip} == -1) { | |||
997 | 2 | 4 | $self->_load_geoip(); | |||
998 | } | |||||
999 | 2 | 4 | if($self->{_have_geoip} == 1) { | |||
1000 | 0 | 0 | $self->{_country} = $self->{_geoip}->country_code_by_addr($ip); | |||
1001 | } | |||||
1002 | 2 | 2 | unless(defined($self->{_country})) { | |||
1003 | 2 | 3 | if($self->{_have_geoipfree} == -1) { | |||
1004 | # Don't use 'eval { use ... ' as recommended by Perlcritic | |||||
1005 | # See https://www.cpantesters.org/cpan/report/6db47260-389e-11ec-bc66-57723b537541 | |||||
1006 | 2 | 57 | eval 'require Geo::IPfree'; | |||
1007 | 2 | 476 | unless($@) { | |||
1008 | 0 | 0 | Geo::IPfree::IP->import(); | |||
1009 | 0 | 0 | $self->{_have_geoipfree} = 1; | |||
1010 | 0 | 0 | $self->{_geoipfree} = Geo::IPfree->new(); | |||
1011 | } else { | |||||
1012 | 2 | 3 | $self->{_have_geoipfree} = 0; | |||
1013 | } | |||||
1014 | } | |||||
1015 | 2 | 3 | if($self->{_have_geoipfree} == 1) { | |||
1016 | 0 | 0 | if(my $country = ($self->{_geoipfree}->LookUp($ip))[0]) { | |||
1017 | 0 | 0 | $self->{_country} = lc($country); | |||
1018 | } | |||||
1019 | } | |||||
1020 | } | |||||
1021 | } | |||||
1022 | 2 | 4 | if($self->{_country} && ($self->{_country} eq 'eu')) { | |||
1023 | 0 | 0 | delete($self->{_country}); | |||
1024 | } | |||||
1025 | 2 | 5 | if((!$self->{_country}) && | |||
1026 | 2 0 | 128 0 | (eval { require LWP::Simple::WithCache; require JSON::Parse } )) { | |||
1027 | 0 | 0 | $self->_debug("Look up $ip on geoplugin"); | |||
1028 | ||||||
1029 | 0 | 0 | LWP::Simple::WithCache->import(); | |||
1030 | 0 | 0 | JSON::Parse->import(); | |||
1031 | ||||||
1032 | 0 | 0 | if(my $data = LWP::Simple::WithCache::get("http://www.geoplugin.net/json.gp?ip=$ip")) { | |||
1033 | 0 | 0 | $self->{_country} = JSON::Parse::parse_json($data)->{'geoplugin_countryCode'}; | |||
1034 | } | |||||
1035 | } | |||||
1036 | 2 | 452 | unless($self->{_country}) { | |||
1037 | 2 | 4 | $self->_debug("Look up $ip on Whois"); | |||
1038 | ||||||
1039 | 2 | 234 | require Net::Whois::IP; | |||
1040 | 2 | 5480 | Net::Whois::IP->import(); | |||
1041 | ||||||
1042 | 2 | 1 | my $whois; | |||
1043 | ||||||
1044 | 2 | 2 | eval { | |||
1045 | # Catch connection timeouts to | |||||
1046 | # whois.ripe.net by turning the carp | |||||
1047 | # into an error | |||||
1048 | 2 0 | 6 0 | local $SIG{__WARN__} = sub { die $_[0] }; | |||
1049 | 2 | 4 | $whois = Net::Whois::IP::whoisip_query($ip); | |||
1050 | }; | |||||
1051 | 2 | 2193014 | unless($@ || !defined($whois) || (ref($whois) ne 'HASH')) { | |||
1052 | 2 | 6 | if(defined($whois->{Country})) { | |||
1053 | 2 | 14 | $self->{_country} = $whois->{Country}; | |||
1054 | } elsif(defined($whois->{country})) { | |||||
1055 | 0 | 0 | $self->{_country} = $whois->{country}; | |||
1056 | } | |||||
1057 | 2 | 5 | if($self->{_country}) { | |||
1058 | 2 | 10 | if($self->{_country} eq 'EU') { | |||
1059 | 0 | 0 | delete($self->{_country}); | |||
1060 | } elsif(($self->{_country} eq 'US') && defined($whois->{'StateProv'}) && ($whois->{'StateProv'} eq 'PR')) { | |||||
1061 | # RT#131347: Despite what Whois thinks, Puerto Rico isn't in the US | |||||
1062 | 0 | 0 | $self->{_country} = 'pr'; | |||
1063 | } | |||||
1064 | } | |||||
1065 | } | |||||
1066 | ||||||
1067 | 2 | 4 | if($self->{_country}) { | |||
1068 | 2 | 8 | $self->_debug("Found up $ip on Net::WhoisIP as ", $self->{_country}); | |||
1069 | } else { | |||||
1070 | 0 | 0 | $self->_debug("Look up $ip on IANA"); | |||
1071 | ||||||
1072 | 0 | 0 | require Net::Whois::IANA; | |||
1073 | 0 | 0 | Net::Whois::IANA->import(); | |||
1074 | ||||||
1075 | 0 | 0 | my $iana = Net::Whois::IANA->new(); | |||
1076 | 0 | 0 | eval { | |||
1077 | 0 | 0 | $iana->whois_query(-ip => $ip); | |||
1078 | }; | |||||
1079 | 0 | 0 | unless ($@) { | |||
1080 | 0 | 0 | $self->{_country} = $iana->country(); | |||
1081 | 0 | 0 | $self->_debug("IANA reports $ip as ", $self->{_country}); | |||
1082 | } | |||||
1083 | } | |||||
1084 | ||||||
1085 | 2 | 64 | if($self->{_country}) { | |||
1086 | # 190.24.1.122 has carriage return in its WHOIS record | |||||
1087 | 2 | 6 | $self->{_country} =~ s/[\r\n]//g; | |||
1088 | 2 | 13 | if($self->{_country} =~ /^(..)\s*#/) { | |||
1089 | # Remove comments in the Whois record | |||||
1090 | 0 | 0 | $self->{_country} = $1; | |||
1091 | } | |||||
1092 | } | |||||
1093 | # TODO - try freegeoip.net if whois has failed | |||||
1094 | } | |||||
1095 | ||||||
1096 | 2 | 3 | if($self->{_country}) { | |||
1097 | 2 | 8 | if($self->{_country} !~ /\D/) { | |||
1098 | 0 | 0 | $self->_warn('IP matches to a numeric country'); | |||
1099 | 0 | 0 | delete $self->{_country}; # Seems to be a number | |||
1100 | } else { | |||||
1101 | 2 | 4 | $self->{_country} = lc($self->{_country}); | |||
1102 | 2 | 7 | if($self->{_country} eq 'hk') { | |||
1103 | # Hong Kong is no longer a country, but Whois thinks | |||||
1104 | # it is - try "whois 218.213.130.87" | |||||
1105 | 0 | 0 | $self->{_country} = 'cn'; | |||
1106 | } elsif($self->{_country} eq 'eu') { | |||||
1107 | 0 | 0 | require Net::Subnet; | |||
1108 | ||||||
1109 | # RT-86809, Baidu claims it's in EU not CN | |||||
1110 | 0 | 0 | Net::Subnet->import(); | |||
1111 | 0 | 0 | if(subnet_matcher('185.10.104.0/22')->($ip)) { | |||
1112 | 0 | 0 | $self->{_country} = 'cn'; | |||
1113 | } else { | |||||
1114 | # There is no country called 'eu' | |||||
1115 | 0 | 0 | $self->_warn({ | |||
1116 | warning => "$ip has country of eu" | |||||
1117 | }); | |||||
1118 | 0 | 0 | $self->{_country} = 'Unknown'; | |||
1119 | } | |||||
1120 | } | |||||
1121 | ||||||
1122 | 2 | 6 | if($self->{_country} !~ /\D/) { | |||
1123 | 0 | 0 | $self->_warn('cache contains a numeric country: ', $self->{_country}); | |||
1124 | 0 | 0 | delete $self->{_country}; # Seems to be a number | |||
1125 | } elsif($self->{_cache}) { | |||||
1126 | 0 | 0 | $self->_debug("Set $ip to $self->{_country}"); | |||
1127 | ||||||
1128 | 0 | 0 | $self->{_cache}->set(__PACKAGE__ . ":country:$ip", $self->{_country}, '1 hour'); | |||
1129 | } | |||||
1130 | } | |||||
1131 | } | |||||
1132 | ||||||
1133 | 2 | 11 | return $self->{_country}; | |||
1134 | } | |||||
1135 | ||||||
1136 | sub _load_geoip | |||||
1137 | { | |||||
1138 | 2 | 3 | my $self = shift; | |||
1139 | ||||||
1140 | # For Windows, see http://www.cpantesters.org/cpan/report/54117bd0-6eaf-1014-8029-ee20cb952333 | |||||
1141 | 2 | 20 | if((($^O eq 'MSWin32') && (-r 'c:/GeoIP/GeoIP.dat')) || | |||
1142 | ((-r '/usr/local/share/GeoIP/GeoIP.dat') || (-r '/usr/share/GeoIP/GeoIP.dat'))) { | |||||
1143 | # Don't use 'eval { use ... ' as recommended by Perlcritic | |||||
1144 | # See https://www.cpantesters.org/cpan/report/6db47260-389e-11ec-bc66-57723b537541 | |||||
1145 | 0 | 0 | eval 'require Geo::IP'; | |||
1146 | 0 | 0 | unless($@) { | |||
1147 | 0 | 0 | Geo::IP->import(); | |||
1148 | 0 | 0 | $self->{_have_geoip} = 1; | |||
1149 | # GEOIP_STANDARD = 0, can't use that because you'll | |||||
1150 | # get a syntax error | |||||
1151 | 0 | 0 | if(-r '/usr/share/GeoIP/GeoIP.dat') { | |||
1152 | 0 | 0 | $self->{_geoip} = Geo::IP->open('/usr/share/GeoIP/GeoIP.dat', 0); | |||
1153 | } else { | |||||
1154 | 0 | 0 | $self->{_geoip} = Geo::IP->new(0); | |||
1155 | } | |||||
1156 | } else { | |||||
1157 | 0 | 0 | $self->{_have_geoip} = 0; | |||
1158 | } | |||||
1159 | } else { | |||||
1160 | 2 | 3 | $self->{_have_geoip} = 0; | |||
1161 | } | |||||
1162 | } | |||||
1163 | ||||||
1164 - 1178 | =head2 locale HTTP doesn't have a way of transmitting a browser's localisation information which would be useful for default currency, date formatting, etc. This method attempts to detect the information, but it is a best guess and is not 100% reliable. But it's better than nothing ;-) Returns a L<Locale::Object::Country> object. To be clear, if you're in the US and request the language in Spanish, and the site supports it, language() will return 'Spanish', and locale() will try to return the Locale::Object::Country for the US. =cut | |||||
1179 | ||||||
1180 | sub locale { | |||||
1181 | 2 | 9 | my $self = shift; | |||
1182 | ||||||
1183 | 2 | 5 | if($self->{_locale}) { | |||
1184 | 0 | 0 | return $self->{_locale}; | |||
1185 | } | |||||
1186 | ||||||
1187 | # First try from the User Agent. Probably only works with Mozilla and | |||||
1188 | # Safari. I don't know about Opera. It won't work with IE or Chrome. | |||||
1189 | 2 | 5 | my $agent = $ENV{'HTTP_USER_AGENT'}; | |||
1190 | 2 | 13 | my $country; | |||
1191 | 2 | 9 | if(defined($agent) && ($agent =~ /\((.+)\)/)) { | |||
1192 | 2 | 7 | foreach(split(/;/, $1)) { | |||
1193 | 7 | 3 | my $candidate = $_; | |||
1194 | ||||||
1195 | 7 | 9 | $candidate =~ s/^\s//g; | |||
1196 | 7 | 8 | $candidate =~ s/\s$//g; | |||
1197 | 7 | 11 | if($candidate =~ /^[a-zA-Z]{2}-([a-zA-Z]{2})$/) { | |||
1198 | 0 | 0 | local $SIG{__WARN__} = undef; | |||
1199 | 0 | 0 | if(my $c = $self->_code2country($1)) { | |||
1200 | 0 | 0 | $self->{_locale} = $c; | |||
1201 | 0 | 0 | return $c; | |||
1202 | } | |||||
1203 | # carp "Warning: unknown country $1 derived from $candidate in HTTP_USER_AGENT ($agent)"; | |||||
1204 | } | |||||
1205 | } | |||||
1206 | ||||||
1207 | 2 2 | 2 832 | if(eval { require HTTP::BrowserDetect; } ) { | |||
1208 | 2 | 15603 | HTTP::BrowserDetect->import(); | |||
1209 | 2 | 4 | my $browser = HTTP::BrowserDetect->new($agent); | |||
1210 | ||||||
1211 | 2 | 164 | if($browser && $browser->country() && (my $c = $self->_code2country($browser->country()))) { | |||
1212 | 1 | 1 | $self->{_locale} = $c; | |||
1213 | 1 | 6 | return $c; | |||
1214 | } | |||||
1215 | } | |||||
1216 | } | |||||
1217 | ||||||
1218 | # Try from the IP address | |||||
1219 | 1 | 54 | $country = $self->country(); | |||
1220 | ||||||
1221 | 1 | 4 | if($country) { | |||
1222 | 1 | 1 | $country =~ s/[\r\n]//g; | |||
1223 | ||||||
1224 | 1 | 2 | my $c; | |||
1225 | 1 | 1 | eval { | |||
1226 | 1 0 | 6 0 | local $SIG{__WARN__} = sub { die $_[0] }; | |||
1227 | 1 | 4 | $c = $self->_code2country($country); | |||
1228 | }; | |||||
1229 | 1 | 2 | unless($@) { | |||
1230 | 1 | 1 | if($c) { | |||
1231 | 1 | 1 | $self->{_locale} = $c; | |||
1232 | 1 | 5 | return $c; | |||
1233 | } | |||||
1234 | } | |||||
1235 | } | |||||
1236 | ||||||
1237 | # Try mod_geoip | |||||
1238 | 0 | 0 | if(defined($ENV{'GEOIP_COUNTRY_CODE'})) { | |||
1239 | 0 | 0 | $country = $ENV{'GEOIP_COUNTRY_CODE'}; | |||
1240 | 0 | 0 | my $c = $self->_code2country($country); | |||
1241 | 0 | 0 | if($c) { | |||
1242 | 0 | 0 | $self->{_locale} = $c; | |||
1243 | 0 | 0 | return $c; | |||
1244 | } | |||||
1245 | } | |||||
1246 | 0 | 0 | return undef; | |||
1247 | } | |||||
1248 | ||||||
1249 - 1256 | =head2 time_zone Returns the timezone of the web client. If L<Geo::IP> is installed, CGI::Lingua will make use of that, otherwise it will use L<ip-api.com> =cut | |||||
1257 | ||||||
1258 | sub time_zone { | |||||
1259 | 1 | 1 | my $self = shift; | |||
1260 | ||||||
1261 | 1 | 5 | $self->_trace('Entered time_zone'); | |||
1262 | ||||||
1263 | 1 | 12 | if($self->{_timezone}) { | |||
1264 | 0 | 0 | $self->_trace('quick return: ', $self->{_timezone}); | |||
1265 | 0 | 0 | return $self->{_timezone}; | |||
1266 | } | |||||
1267 | ||||||
1268 | 1 | 3 | if(my $ip = $ENV{'REMOTE_ADDR'}) { | |||
1269 | 1 | 1 | if($self->{_have_geoip} == -1) { | |||
1270 | 0 | 0 | $self->_load_geoip(); | |||
1271 | } | |||||
1272 | 1 | 2 | if($self->{_have_geoip} == 1) { | |||
1273 | 0 | 0 | eval { | |||
1274 | 0 | 0 | $self->{_timezone} = $self->{_geoip}->time_zone($ip); | |||
1275 | }; | |||||
1276 | } | |||||
1277 | 1 | 2 | if(!$self->{_timezone}) { | |||
1278 | 1 1 0 | 1 68 0 | if(eval { require LWP::Simple::WithCache; require JSON::Parse } ) { | |||
1279 | 0 | 0 | $self->_debug("Look up $ip on ip-api.com"); | |||
1280 | ||||||
1281 | 0 | 0 | LWP::Simple::WithCache->import(); | |||
1282 | 0 | 0 | JSON::Parse->import(); | |||
1283 | ||||||
1284 | 0 | 0 | if(my $data = LWP::Simple::WithCache::get("http://ip-api.com/json/$ip")) { | |||
1285 | 0 | 0 | $self->{_timezone} = JSON::Parse::parse_json($data)->{'timezone'}; | |||
1286 | } | |||||
1287 | 1 1 | 323 178 | } elsif(eval { require LWP::Simple; require JSON::Parse } ) { | |||
1288 | 1 | 616 | $self->_debug("Look up $ip on ip-api.com"); | |||
1289 | ||||||
1290 | 1 | 17 | LWP::Simple->import(); | |||
1291 | 1 | 221 | JSON::Parse->import(); | |||
1292 | ||||||
1293 | 1 | 3 | if(my $data = LWP::Simple::get("http://ip-api.com/json/$ip")) { | |||
1294 | 1 | 88744 | $self->{_timezone} = JSON::Parse::parse_json($data)->{'timezone'}; | |||
1295 | } | |||||
1296 | } else { | |||||
1297 | 0 | 0 | if(my $logger = $self->{'logger'}) { | |||
1298 | 0 | 0 | $logger->error('You must have LWP::Simple::WithCache installed to connect to ip-api.com'); | |||
1299 | } | |||||
1300 | 0 | 0 | Carp::croak('You must have LWP::Simple::WithCache or LWP::Simple installed to connect to ip-api.com'); | |||
1301 | } | |||||
1302 | } | |||||
1303 | } else { | |||||
1304 | # Not a remote connection | |||||
1305 | 0 | 0 | if(open(my $fin, '<', '/etc/timezone')) { | |||
1306 | 0 | 0 | my $tz = <$fin>; | |||
1307 | 0 | 0 | chomp $tz; | |||
1308 | 0 | 0 | $self->{_timezone} = $tz; | |||
1309 | } else { | |||||
1310 | 0 | 0 | $self->{_timezone} = DateTime::TimeZone::Local->TimeZone()->name(); | |||
1311 | } | |||||
1312 | } | |||||
1313 | ||||||
1314 | 1 | 6 | if(!defined($self->{_timezone})) { | |||
1315 | 0 | 0 | $self->_warn("Couldn't determine the timezone"); | |||
1316 | } | |||||
1317 | 1 | 6 | return $self->{_timezone}; | |||
1318 | } | |||||
1319 | ||||||
1320 | # Wrapper to Locale::Language::code2language which makes use of the cache | |||||
1321 | sub _code2language | |||||
1322 | { | |||||
1323 | 27 | 26 | my ($self, $code) = @_; | |||
1324 | ||||||
1325 | 27 | 30 | return unless($code); | |||
1326 | 27 | 33 | if(defined($self->{_country})) { | |||
1327 | 2 | 4 | $self->_debug("_code2language $code, country ", $self->{_country}); | |||
1328 | } else { | |||||
1329 | 25 | 33 | $self->_debug("_code2language $code"); | |||
1330 | } | |||||
1331 | 27 | 380 | unless($self->{_cache}) { | |||
1332 | 21 | 42 | return Locale::Language::code2language($code); | |||
1333 | } | |||||
1334 | 6 | 12 | if(my $from_cache = $self->{_cache}->get(__PACKAGE__ . ":code2language:$code")) { | |||
1335 | 5 | 396 | $self->_trace("_code2language found in cache $from_cache"); | |||
1336 | 5 | 56 | return $from_cache; | |||
1337 | } | |||||
1338 | 1 | 44 | $self->_trace('_code2language not in cache, storing'); | |||
1339 | 1 | 14 | return $self->{_cache}->set(__PACKAGE__ . ":code2language:$code", Locale::Language::code2language($code), '1 month'); | |||
1340 | } | |||||
1341 | ||||||
1342 | # Wrapper to Locale::Object::Country allowing for persistence to be added | |||||
1343 | sub _code2country | |||||
1344 | { | |||||
1345 | 21 | 78 | my ($self, $code) = @_; | |||
1346 | ||||||
1347 | 21 | 25 | return unless($code); | |||
1348 | 21 | 29 | if($self->{_country}) { | |||
1349 | 3 | 10 | $self->_trace(">_code2country $code, country ", $self->{_country}); | |||
1350 | } else { | |||||
1351 | 18 | 28 | $self->_trace(">_code2country $code"); | |||
1352 | } | |||||
1353 | local $SIG{__WARN__} = sub { | |||||
1354 | 1 | 309 | if($_[0] !~ /No result found in country table/) { | |||
1355 | 0 | 0 | warn $_[0]; | |||
1356 | } | |||||
1357 | 21 | 341 | }; | |||
1358 | 21 | 92 | my $rc = Locale::Object::Country->new(code_alpha2 => $code); | |||
1359 | 21 | 1603452 | local $SIG{__WARN__} = 'DEFAULT'; | |||
1360 | 21 | 59 | $self->_trace('<_code2country ', $code || 'undef'); | |||
1361 | 21 | 465 | return $rc; | |||
1362 | } | |||||
1363 | ||||||
1364 | # Wrapper to Locale::Object::Country->name which makes use of the cache | |||||
1365 | sub _code2countryname | |||||
1366 | { | |||||
1367 | 17 | 17 | my ($self, $code) = @_; | |||
1368 | ||||||
1369 | 17 | 25 | return unless($code); | |||
1370 | 17 | 32 | $self->_trace(">_code2countryname $code"); | |||
1371 | 17 | 297 | unless($self->{_cache}) { | |||
1372 | 13 | 24 | my $country = $self->_code2country($code); | |||
1373 | 13 | 19 | if(defined($country)) { | |||
1374 | 13 | 26 | return $country->name; | |||
1375 | } | |||||
1376 | 0 | 0 | return; | |||
1377 | } | |||||
1378 | 4 | 22 | if(my $from_cache = $self->{_cache}->get(__PACKAGE__ . ":code2countryname:$code")) { | |||
1379 | 2 | 123 | $self->_trace("_code2countryname found in cache $from_cache"); | |||
1380 | 2 | 20 | return $from_cache; | |||
1381 | } | |||||
1382 | 2 | 92 | if(my $country = $self->_code2country($code)) { | |||
1383 | 2 | 4 | $self->_debug('_code2countryname not in cache, storing'); | |||
1384 | 2 | 23 | $self->_trace('<_code2countryname ', $country->name()); | |||
1385 | 2 | 23 | return $self->{_cache}->set(__PACKAGE__ . ":code2countryname:$code", $country->name(), '1 month'); | |||
1386 | } | |||||
1387 | 0 | 0 | $self->_trace('<_code2countryname undef'); | |||
1388 | } | |||||
1389 | ||||||
1390 | # Log and remember a message | |||||
1391 | sub _log | |||||
1392 | { | |||||
1393 | 465 | 442 | my ($self, $level, @messages) = @_; | |||
1394 | ||||||
1395 | 465 | 393 | if(scalar(@messages)) { | |||
1396 | # FIXME: add caller's function | |||||
1397 | # if(($level eq 'warn') || ($level eq 'notice')) { | |||||
1398 | 465 465 | 260 934 | push @{$self->{'messages'}}, { level => $level, message => join('', grep defined, @messages) }; | |||
1399 | # } | |||||
1400 | ||||||
1401 | 465 | 486 | if(my $logger = $self->{'logger'}) { | |||
1402 | 465 | 749 | $self->{'logger'}->$level(join('', grep defined, @messages)); | |||
1403 | } | |||||
1404 | } | |||||
1405 | } | |||||
1406 | ||||||
1407 | sub _debug { | |||||
1408 | 241 | 151 | my $self = shift; | |||
1409 | 241 | 218 | $self->_log('debug', @_); | |||
1410 | } | |||||
1411 | ||||||
1412 | sub _info { | |||||
1413 | 1 | 294 | my $self = shift; | |||
1414 | 1 | 19 | $self->_log('info', @_); | |||
1415 | } | |||||
1416 | ||||||
1417 | sub _notice { | |||||
1418 | 2 | 15 | my $self = shift; | |||
1419 | 2 | 4 | $self->_log('notice', @_); | |||
1420 | } | |||||
1421 | ||||||
1422 | sub _trace { | |||||
1423 | 221 | 172 | my $self = shift; | |||
1424 | 221 | 219 | $self->_log('trace', @_); | |||
1425 | } | |||||
1426 | ||||||
1427 | # Emit a warning message somewhere | |||||
1428 | sub _warn | |||||
1429 | { | |||||
1430 | 1 | 7 | my $self = shift; | |||
1431 | 1 | 2 | if(defined($self->{'logger'})) { | |||
1432 | 1 | 1 | $self->{'logger'}->warn(\@_); | |||
1433 | } else { | |||||
1434 | # This shouldn't happen, since Object::Configure always sets something | |||||
1435 | 0 | my $params = Params::Get::get_params('warning', @_); | ||||
1436 | ||||||
1437 | 0 | $self->_log('warn', $params->{'warning'}); | ||||
1438 | 0 | Carp::carp($params->{'warning'}); | ||||
1439 | } | |||||
1440 | } | |||||
1441 | ||||||
1442 - 1520 | =head1 AUTHOR Nigel Horne, C<< <njh at nigelhorne.com> >> =head1 BUGS Please report any bugs or feature requests to the author. If HTTP_ACCEPT_LANGUAGE is 3 characters, e.g., es-419, sublanguage() returns undef. Please report any bugs or feature requests to C<bug-cgi-lingua at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CGI-Lingua>. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. Uses L<I18N::Acceptlanguage> to find the highest priority accepted language. This means that if you support languages at a lower priority, it may be missed. =head1 SEE ALSO =over 4 =item * Testing Dashboard L<https://nigelhorne.github.io/CGI-Lingua/coverage/> =item * VWF - Versatile Web Framework L<https://github.com/nigelhorne/vwf> =item * L<HTTP::BrowserDetect> =item * L<I18N::AcceptLangauge> =item * L<Locale::Country> =back =head1 SUPPORT This module is provided as-is without any warranty. You can find documentation for this module with the perldoc command. perldoc CGI::Lingua You can also look for information at: =over 4 =item * MetaCPAN L<https://metacpan.org/release/CGI-Lingua> =item * RT: CPAN's request tracker L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=CGI-Lingua> =item * CPANTS L<http://cpants.cpanauthors.org/dist/CGI-Lingua> =item * CPAN Testers' Matrix L<http://matrix.cpantesters.org/?dist=CGI-Lingua> =item * CPAN Testers Dependencies L<http://deps.cpantesters.org/?module=CGI::Lingua> =back =head1 ACKNOWLEDGEMENTS =head1 LICENSE AND COPYRIGHT Copyright 2010-2025 Nigel Horne. This program is released under the following licence: GPL2 =cut | |||||
1521 | ||||||
1522 | 1; # End of CGI::Lingua |