| File: | blib/lib/CGI/Lingua.pm |
| Coverage: | 80.9% |
| line | stmt | bran | cond | sub | time | code |
|---|---|---|---|---|---|---|
| 1 | package CGI::Lingua; | |||||
| 2 | ||||||
| 3 | 27 27 27 | 1869126 22 558 | use warnings; | |||
| 4 | 27 27 27 | 41 20 253 | use strict; | |||
| 5 | 27 27 27 | 3259 105977 62 | use autodie qw(:file); | |||
| 6 | ||||||
| 7 | 27 27 27 | 19723 1730055 523 | use Object::Configure 0.14; | |||
| 8 | 27 27 27 | 85 122 434 | use Params::Get 0.13; | |||
| 9 | 27 27 27 | 50 20 461 | use Readonly; | |||
| 10 | 27 27 27 | 72 22 418 | use Scalar::Util qw(blessed); | |||
| 11 | 27 27 27 | 52 21 570 | use Storable; | |||
| 12 | 27 | 76 | use Class::Autouse qw{ | |||
| 13 | Carp | |||||
| 14 | Locale::Language | |||||
| 15 | Locale::Object::Country | |||||
| 16 | Locale::Object::DB | |||||
| 17 | I18N::AcceptLanguage | |||||
| 18 | I18N::LangTags::Detect | |||||
| 19 | 27 27 | 6605 83559 | }; | |||
| 20 | ||||||
| 21 | our $VERSION = '0.81'; | |||||
| 22 | ||||||
| 23 | # ââ Module-level constants âââââââââââââââââââââââââââââââââââââââââââââââââââ | |||||
| 24 | # Gathering magic strings here makes behavioural changes one-edit operations. | |||||
| 25 | ||||||
| 26 | Readonly my $CACHE_TTL_LONG => '1 month'; | |||||
| 27 | Readonly my $CACHE_TTL_SHORT => '1 hour'; | |||||
| 28 | Readonly my $CACHE_NS => 'CGI::Lingua:'; # namespace prefix for every key | |||||
| 29 | Readonly my $BROKEN_GEOIPFREE => '45.128.139.41'; # https://github.com/bricas/geo-ipfree/issues/10 | |||||
| 30 | Readonly my $BAIDU_SUBNET => '185.10.104.0/22';# RT-86809: Baidu misreports as EU | |||||
| 31 | Readonly my $DEPRECATED_EN_UK => 'en-uk'; # some browsers still send this | |||||
| 32 | Readonly my $CANONICAL_EN_GB => 'en-gb'; | |||||
| 33 | Readonly my $ACCEPT_LANG_MAX => 256; # max bytes we accept from the header | |||||
| 34 | Readonly my $GEO_UNKNOWN => -1; # geo-module sentinel: not yet probed | |||||
| 35 | Readonly my $GEO_ABSENT => 0; # geo-module sentinel: unavailable | |||||
| 36 | Readonly my $GEO_PRESENT => 1; # geo-module sentinel: loaded OK | |||||
| 37 | Readonly my %RTL_LANGS => (map { $_ => 1 } # ISO 639-1 codes whose primary script is RTL | |||||
| 38 | qw(ar dv fa he ku ps sd ug ur yi)); | |||||
| 39 | ||||||
| 40 - 48 | =head1 NAME CGI::Lingua - Create a multilingual web page =head1 VERSION Version 0.80 =cut | |||||
| 49 | ||||||
| 50 - 125 | =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.
=head3 API SPECIFICATION
Input:
supported => ArrayRef[Str] | Str # required; RFC-1766 language codes
cache => Object # optional; CHI-compatible (get/set)
config_file => Str # optional; YAML/XML/INI config path
logger => Object # optional; must implement warn/info/error
info => Object # optional; CGI::Info-compatible
data => Any # optional; forwarded to I18N::AcceptLanguage
dont_use_ip => Bool # optional; disable IP-based fallback
syslog => Bool | HashRef # optional; Sys::Syslog integration
debug => Bool # optional; enable debug logging
Returns: CGI::Lingua blessed hashref, or a clone when called on an object.
=head3 MESSAGES
"You must give a list of supported languages" - no 'supported' key provided
"List of supported languages must be an array ref" - supported is wrong ref type
"Supported languages must be the short code" - string too short or too long
"Logger must be a blessed object with warn/info/error methods" - bad logger arg
=head3 PSEUDOCODE
1. Normalise args via Params::Get and Object::Configure
2. Validate logger (must be blessed with warn/info/error) if provided
3. Validate supported (required, string or arrayref)
4. If cache and REMOTE_ADDR set, attempt to thaw a previously stored state
5. Bless and return fresh object with sentinel flags set to GEO_UNKNOWN
=cut | |||||
| 126 | ||||||
| 127 | sub new | |||||
| 128 | { | |||||
| 129 | 1645 | 3593406 | my $class = shift; | |||
| 130 | 1645 | 2186 | my $params = Params::Get::get_params('supported', @_); | |||
| 131 | ||||||
| 132 | # Handle ::new() misuse | |||||
| 133 | 1641 | 26354 | if(!defined($class)) { | |||
| 134 | 2 | 2 | if($params) { | |||
| 135 | 2 | 4 | if(my $logger = $params->{'logger'}) { | |||
| 136 | 0 | 0 | $logger->error(__PACKAGE__ . ' use ->new() not ::new() to instantiate'); | |||
| 137 | } | |||||
| 138 | 2 | 15 | Carp::croak(__PACKAGE__ . ' use ->new() not ::new() to instantiate'); | |||
| 139 | } | |||||
| 140 | 0 | 0 | $class = __PACKAGE__; | |||
| 141 | } elsif(ref($class)) { | |||||
| 142 | # Clone: overlay new params onto existing object state | |||||
| 143 | 3 | 12 | $params->{_supported} ||= $params->{supported} if defined $params->{'supported'}; | |||
| 144 | 3 3 3 | 2 9 11 | return bless { %{$class}, %{$params} }, ref($class); | |||
| 145 | } | |||||
| 146 | ||||||
| 147 | # Validate blessed logger objects before Object::Configure runs. | |||||
| 148 | # Non-blessed values (arrayrefs, hashrefs) are valid config forms that | |||||
| 149 | # Object::Configure knows how to convert into a Log::Abstraction instance. | |||||
| 150 | 1636 | 1866 | if(defined $params->{'logger'} && blessed($params->{'logger'})) { | |||
| 151 | 7 | 33 | unless( | |||
| 152 | $params->{'logger'}->can('warn') | |||||
| 153 | && $params->{'logger'}->can('info') | |||||
| 154 | && $params->{'logger'}->can('error') | |||||
| 155 | ) { | |||||
| 156 | 3 | 210 | Carp::croak('Logger must be a blessed object with warn/info/error methods'); | |||
| 157 | } | |||||
| 158 | } | |||||
| 159 | ||||||
| 160 | 1633 | 2507 | $params = Object::Configure::configure($class, $params); | |||
| 161 | ||||||
| 162 | # Normalise supported / supported_languages alias | |||||
| 163 | 1633 | 2971994 | $params->{'supported'} ||= $params->{'supported_languages'}; | |||
| 164 | 1633 | 2213 | if(defined($params->{supported})) { | |||
| 165 | # Validate supported type/length | |||||
| 166 | 1627 | 3230 | if(ref($params->{supported})) { | |||
| 167 | 596 | 915 | if(ref($params->{supported}) ne 'ARRAY') { | |||
| 168 | 243 | 3195 | Carp::croak('List of supported languages must be an array ref'); | |||
| 169 | } | |||||
| 170 | } elsif((length($params->{supported}) < 2) || (length($params->{supported}) > 5)) { | |||||
| 171 | 185 | 2744 | Carp::croak('Supported languages must be the short code'); | |||
| 172 | } | |||||
| 173 | } else { | |||||
| 174 | 6 | 16 | if(my $logger = $params->{'logger'}) { | |||
| 175 | 6 | 18 | $logger->error('You must give a list of supported languages'); | |||
| 176 | } | |||||
| 177 | 6 | 2039 | Carp::croak('You must give a list of supported languages'); | |||
| 178 | } | |||||
| 179 | ||||||
| 180 | 1200 | 1315 | my $cache = $params->{cache}; | |||
| 181 | 1200 | 822 | my $info = $params->{info}; | |||
| 182 | ||||||
| 183 | # Try to restore a frozen state from the cache before doing any work | |||||
| 184 | 1200 | 1378 | if($cache && $ENV{'REMOTE_ADDR'}) { | |||
| 185 | 31 | 55 | my $key = _build_cache_key($ENV{'REMOTE_ADDR'}, $params, $class, $info); | |||
| 186 | 31 | 82 | if(my $rc = $cache->get($key)) { | |||
| 187 | 6 | 568 | $rc = Storable::thaw($rc); | |||
| 188 | # Re-inject transient/non-serialisable fields | |||||
| 189 | 6 | 124 | $rc->{logger} = $params->{'logger'}; | |||
| 190 | 6 | 9 | $rc->{_syslog} = $params->{syslog}; | |||
| 191 | 6 | 14 | $rc->{_cache} = $cache; | |||
| 192 | 6 | 11 | $rc->{_supported} = $params->{supported}; | |||
| 193 | 6 | 6 | $rc->{_info} = $info; | |||
| 194 | 6 | 13 | $rc->{_have_ipcountry} = $GEO_UNKNOWN; | |||
| 195 | 6 | 18 | $rc->{_have_geoip} = $GEO_UNKNOWN; | |||
| 196 | 6 | 15 | $rc->{_have_geoipfree} = $GEO_UNKNOWN; | |||
| 197 | ||||||
| 198 | # If lang= CGI param is active, the cached language choice may be stale | |||||
| 199 | 6 | 47 | if(($rc->{_what_language} || $rc->{_rlanguage}) && $info && $info->lang()) { | |||
| 200 | 0 0 | 0 0 | delete @{$rc}{qw(_what_language _rlanguage _country)}; | |||
| 201 | } | |||||
| 202 | 6 | 19 | return $rc; | |||
| 203 | } | |||||
| 204 | } | |||||
| 205 | ||||||
| 206 | return bless { | |||||
| 207 | 1194 | 7135 | %{$params}, | |||
| 208 | _supported => ref($params->{supported}) ? $params->{supported} : [ $params->{'supported'} ], | |||||
| 209 | _cache => $cache, | |||||
| 210 | _info => $info, | |||||
| 211 | _syslog => $params->{syslog}, | |||||
| 212 | _dont_use_ip => $params->{dont_use_ip} || 0, | |||||
| 213 | _have_ipcountry => $GEO_UNKNOWN, | |||||
| 214 | _have_geoip => $GEO_UNKNOWN, | |||||
| 215 | _have_geoipfree => $GEO_UNKNOWN, | |||||
| 216 | 1194 | 1987 | _debug => $params->{debug} || 0, | |||
| 217 | }, $class; | |||||
| 218 | } | |||||
| 219 | ||||||
| 220 | # ââ _build_cache_key ââââââââââââââââââââââââââââââââââââââââââââââââââââââââââ | |||||
| 221 | # Purpose: Produce a deterministic string key for the per-request cache | |||||
| 222 | # entry stored in new() and DESTROY(). | |||||
| 223 | # Entry: $addr â IP string (not yet taint-checked; used read-only here) | |||||
| 224 | # $params â constructor params hashref | |||||
| 225 | # $class â package name | |||||
| 226 | # $info â optional CGI::Info object | |||||
| 227 | # Exit: A plain string key of the form "ip/lang/lang1/lang2/..." | |||||
| 228 | sub _build_cache_key | |||||
| 229 | { | |||||
| 230 | 70 | 50120 | my ($addr, $params, $class, $info) = @_; | |||
| 231 | ||||||
| 232 | 70 | 73 | my $key = "$addr/"; | |||
| 233 | ||||||
| 234 | # Include the requested language (if determinable) so different | |||||
| 235 | # Accept-Language values get distinct cache slots for the same IP. | |||||
| 236 | 70 | 46 | my $l; | |||
| 237 | 70 | 210 | if($info && ($l = $info->lang())) { | |||
| 238 | 3 | 9 | $key .= "$l/"; | |||
| 239 | } elsif($l = $class->_what_language()) { | |||||
| 240 | 46 | 54 | $key .= "$l/"; | |||
| 241 | } | |||||
| 242 | ||||||
| 243 | # Fix: was ref($params->{'supported'} eq 'ARRAY') â eq was inside ref(), | |||||
| 244 | # so ref() always received a boolean (1 or ''), never the arrayref itself. | |||||
| 245 | # Result: arrayref-supported always fell through to the else branch and | |||||
| 246 | # stringified to 'ARRAY(0x...)' â a different address every request â | |||||
| 247 | # making cache lookups in new() permanently fail. | |||||
| 248 | 70 | 101 | if(ref($params->{'supported'}) eq 'ARRAY') { | |||
| 249 | 69 69 | 48 89 | $key .= join('/', @{$params->{supported}}); | |||
| 250 | } else { | |||||
| 251 | 1 | 1 | $key .= $params->{'supported'}; | |||
| 252 | } | |||||
| 253 | ||||||
| 254 | 70 | 85 | return $key; | |||
| 255 | } | |||||
| 256 | ||||||
| 257 | # Some of the information takes a long time to work out, so cache what we can | |||||
| 258 | sub DESTROY { | |||||
| 259 | 1228 | 252628 | if(defined($^V) && ($^V ge 'v5.14.0')) { | |||
| 260 | 1228 | 1744 | return if ${^GLOBAL_PHASE} eq 'DESTRUCT'; | |||
| 261 | } | |||||
| 262 | 1228 | 5522 | return unless $ENV{'REMOTE_ADDR'}; | |||
| 263 | ||||||
| 264 | 175 | 128 | my $self = shift; | |||
| 265 | 175 | 160 | return unless ref($self); | |||
| 266 | ||||||
| 267 | 175 | 249 | my $cache = $self->{_cache}; | |||
| 268 | 175 | 1135 | return unless $cache; | |||
| 269 | ||||||
| 270 | my $key = _build_cache_key( | |||||
| 271 | $ENV{'REMOTE_ADDR'}, | |||||
| 272 | { supported => $self->{_supported} }, | |||||
| 273 | ref($self), | |||||
| 274 | $self->{_info}, | |||||
| 275 | 32 | 81 | ); | |||
| 276 | 32 | 51 | return if $cache->get($key); | |||
| 277 | ||||||
| 278 | 26 | 924 | $self->_debug("Storing self in cache as $key"); | |||
| 279 | ||||||
| 280 | # Freeze only the computed state â not loggers, file handles, or | |||||
| 281 | # geo-module objects (they are re-initialised on next construction). | |||||
| 282 | my $copy = bless { | |||||
| 283 | _slanguage => $self->{_slanguage}, | |||||
| 284 | _slanguage_code_alpha2 => $self->{_slanguage_code_alpha2}, | |||||
| 285 | _sublanguage_code_alpha2 => $self->{_sublanguage_code_alpha2}, | |||||
| 286 | _country => $self->{_country}, | |||||
| 287 | _rlanguage => $self->{_rlanguage}, | |||||
| 288 | _dont_use_ip => $self->{_dont_use_ip}, | |||||
| 289 | _have_ipcountry => $self->{_have_ipcountry}, | |||||
| 290 | _have_geoip => $self->{_have_geoip}, | |||||
| 291 | _have_geoipfree => $self->{_have_geoipfree}, | |||||
| 292 | 26 | 892 | }, ref($self); | |||
| 293 | ||||||
| 294 | 26 | 66 | $cache->set($key, Storable::nfreeze($copy), $CACHE_TTL_LONG); | |||
| 295 | } | |||||
| 296 | ||||||
| 297 - 313 | =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'. =head3 API SPECIFICATION Input: none beyond $self Returns: Str - human-readable language name, or 'Unknown' =cut | |||||
| 314 | ||||||
| 315 | sub language { | |||||
| 316 | 142 | 5944 | my $self = $_[0]; | |||
| 317 | ||||||
| 318 | 142 | 306 | $self->_find_language() unless $self->{_slanguage}; | |||
| 319 | 142 | 633 | return $self->{_slanguage}; | |||
| 320 | } | |||||
| 321 | ||||||
| 322 - 326 | =head2 preferred_language Same as language(). =cut | |||||
| 327 | ||||||
| 328 | sub preferred_language | |||||
| 329 | { | |||||
| 330 | 7 | 41 | my $self = shift; | |||
| 331 | 7 | 16 | return $self->language(@_); | |||
| 332 | } | |||||
| 333 | ||||||
| 334 - 338 | =head2 name Synonym for language, for compatibility with Locale::Object::Language. =cut | |||||
| 339 | ||||||
| 340 | sub name { | |||||
| 341 | 7 | 23 | my $self = $_[0]; | |||
| 342 | 7 | 30 | return $self->language(); | |||
| 343 | } | |||||
| 344 | ||||||
| 345 - 355 | =head2 sublanguage Tells the CGI what variant to use e.g. 'United Kingdom', or undef if it can't be determined. =head3 API SPECIFICATION Input: none beyond $self Returns: Str | undef =cut | |||||
| 356 | ||||||
| 357 | sub sublanguage { | |||||
| 358 | 45 | 107 | my $self = $_[0]; | |||
| 359 | ||||||
| 360 | 45 | 65 | $self->_trace('Entered sublanguage'); | |||
| 361 | 45 | 1355 | $self->_find_language() unless $self->{_slanguage}; | |||
| 362 | 45 | 99 | $self->_trace('Leaving sublanguage ', ($self->{_sublanguage} || 'undef')); | |||
| 363 | 45 | 1149 | return $self->{_sublanguage}; | |||
| 364 | } | |||||
| 365 | ||||||
| 366 - 379 | =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. =head3 API SPECIFICATION Input: none beyond $self Returns: Str (2 chars) | undef =cut | |||||
| 380 | ||||||
| 381 | sub language_code_alpha2 { | |||||
| 382 | 61 | 75 | my $self = $_[0]; | |||
| 383 | ||||||
| 384 | 61 | 69 | $self->_trace('Entered language_code_alpha2'); | |||
| 385 | 61 | 2162 | $self->_find_language() unless $self->{_slanguage}; | |||
| 386 | 61 | 74 | $self->_trace('language_code_alpha2 returns ', $self->{_slanguage_code_alpha2}); | |||
| 387 | 61 | 1798 | return $self->{_slanguage_code_alpha2}; | |||
| 388 | } | |||||
| 389 | ||||||
| 390 - 394 | =head2 code_alpha2 Synonym for language_code_alpha2, kept for historical reasons. =cut | |||||
| 395 | ||||||
| 396 | sub code_alpha2 { | |||||
| 397 | 14 | 661 | my $self = $_[0]; | |||
| 398 | 14 | 26 | return $self->language_code_alpha2(); | |||
| 399 | } | |||||
| 400 | ||||||
| 401 - 411 | =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. =head3 API SPECIFICATION Input: none beyond $self Returns: Str (2 chars) | undef =cut | |||||
| 412 | ||||||
| 413 | sub sublanguage_code_alpha2 { | |||||
| 414 | 19 | 795 | my $self = $_[0]; | |||
| 415 | ||||||
| 416 | 19 | 40 | $self->_find_language() unless $self->{_slanguage}; | |||
| 417 | 19 | 35 | return $self->{_sublanguage_code_alpha2}; | |||
| 418 | } | |||||
| 419 | ||||||
| 420 - 433 | =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)" =head3 API SPECIFICATION Input: none beyond $self Returns: Str - e.g. "English (United Kingdom)" or "Unknown" =cut | |||||
| 434 | ||||||
| 435 | sub requested_language { | |||||
| 436 | 64 | 7583 | my $self = $_[0]; | |||
| 437 | ||||||
| 438 | 64 | 114 | $self->_find_language() unless $self->{_rlanguage}; | |||
| 439 | 64 | 186 | return $self->{_rlanguage}; | |||
| 440 | } | |||||
| 441 | ||||||
| 442 | # ââ _find_language âââââââââââââââââââââââââââââââââââââââââââââââââââââââââ | |||||
| 443 | # Purpose: Populate _slanguage, _rlanguage, _sublanguage, and the | |||||
| 444 | # various code fields by working through the detection pipeline: | |||||
| 445 | # Accept-Language header â I18N::AcceptLanguage â IP country. | |||||
| 446 | # Entry: $self->{_slanguage} must be undef (guards repeated calls). | |||||
| 447 | # Exit: $self->{_slanguage} is set to a language name or 'Unknown'. | |||||
| 448 | # Side Effects: Populates _rlanguage, _sublanguage, *_code_alpha2 fields. | |||||
| 449 | sub _find_language | |||||
| 450 | { | |||||
| 451 | 165 | 896 | my $self = shift; | |||
| 452 | ||||||
| 453 | 165 | 225 | $self->_trace('Entered _find_language'); | |||
| 454 | ||||||
| 455 | 165 | 6933 | $self->{_rlanguage} = 'Unknown'; | |||
| 456 | 165 | 162 | $self->{_slanguage} = 'Unknown'; | |||
| 457 | ||||||
| 458 | 165 | 215 | my $http_accept_language = $self->_what_language(); | |||
| 459 | 165 | 194 | if(defined($http_accept_language)) { | |||
| 460 | $self->_debug( | |||||
| 461 | "language wanted: $http_accept_language, " | |||||
| 462 | . 'languages supported: ' | |||||
| 463 | 143 143 | 163 357 | . join(', ', @{$self->{_supported}} // '') | |||
| 464 | ); | |||||
| 465 | ||||||
| 466 | # Normalise the deprecated en-uk tag that some browsers send | |||||
| 467 | 143 | 4217 | if($http_accept_language eq $DEPRECATED_EN_UK) { | |||
| 468 | 5 | 38 | $self->_debug("Resetting country code to GB for $http_accept_language"); | |||
| 469 | 5 | 145 | $http_accept_language = $CANONICAL_EN_GB; | |||
| 470 | } | |||||
| 471 | ||||||
| 472 | # Run the header through the Accept-Language resolver | |||||
| 473 | 143 | 467 | my ($l, $requested_sublanguage) = | |||
| 474 | $self->_accept_language_match($http_accept_language); | |||||
| 475 | ||||||
| 476 | # Resolve the matched code to a full language/sublanguage | |||||
| 477 | 143 | 196 | if($l) { | |||
| 478 | 120 | 169 | return if $self->_resolve_match($l, $requested_sublanguage, $http_accept_language); | |||
| 479 | } elsif($http_accept_language =~ /;/) { | |||||
| 480 | # e.g. de-DE,de;q=0.9,en-US;q=0.8 and we support none of those | |||||
| 481 | $self->_notice( | |||||
| 482 | __PACKAGE__, ': ', __LINE__, | |||||
| 483 | ": couldn't honour HTTP_ACCEPT_LANGUAGE=$http_accept_language," | |||||
| 484 | . ' supported languages are: ' | |||||
| 485 | 2 2 | 2 7 | . join(',', @{$self->{_supported}}) | |||
| 486 | ); | |||||
| 487 | } | |||||
| 488 | ||||||
| 489 | # Detected slanguage but rlanguage still Unknown â try I18N::LangTags | |||||
| 490 | 25 | 92 | if($self->{_slanguage} && ($self->{_slanguage} ne 'Unknown')) { | |||
| 491 | 0 | 0 | if($self->{_rlanguage} eq 'Unknown') { | |||
| 492 | 0 | 0 | $self->{_rlanguage} = I18N::LangTags::Detect::detect(); | |||
| 493 | } | |||||
| 494 | 0 | 0 | if($self->{_rlanguage}) { | |||
| 495 | 0 | 0 | if(my $resolved = $self->_code2language($self->{_rlanguage})) { | |||
| 496 | 0 | 0 | $self->{_rlanguage} = $resolved; | |||
| 497 | } | |||||
| 498 | 0 | 0 | return; | |||
| 499 | } | |||||
| 500 | } | |||||
| 501 | ||||||
| 502 | # Last-chance: 2-char or xx-xx header where we have no match | |||||
| 503 | 25 | 112 | if( | |||
| 504 | ((!$self->{_rlanguage}) || ($self->{_rlanguage} eq 'Unknown')) | |||||
| 505 | && ((length($http_accept_language) == 2) || ($http_accept_language =~ /^..-..$/)) | |||||
| 506 | ) { | |||||
| 507 | 16 | 24 | $self->{_rlanguage} = $self->_code2language($http_accept_language) || 'Unknown'; | |||
| 508 | } | |||||
| 509 | 25 | 89082 | $self->{_slanguage} = 'Unknown'; | |||
| 510 | } | |||||
| 511 | ||||||
| 512 | 47 | 65 | return if $self->{_dont_use_ip}; | |||
| 513 | ||||||
| 514 | # Fall back to the official language of the visitor's country | |||||
| 515 | 46 | 78 | $self->_find_language_from_ip($http_accept_language); | |||
| 516 | } | |||||
| 517 | ||||||
| 518 | # ââ _accept_language_match ââââââââââââââââââââââââââââââââââââââââââââââââ | |||||
| 519 | # Purpose: Run I18N::AcceptLanguage strict matching plus two fallback | |||||
| 520 | # left-to-right scan passes against $self->{_supported}. | |||||
| 521 | # Entry: $http_accept_language â validated, untainted Accept-Language value. | |||||
| 522 | # Exit: Returns ($matched_code, $requested_sublanguage) or (undef, undef). | |||||
| 523 | # Side Effects: Logs debug messages. | |||||
| 524 | sub _accept_language_match | |||||
| 525 | { | |||||
| 526 | 143 | 156 | my ($self, $http_accept_language) = @_; | |||
| 527 | ||||||
| 528 | # Suppress I18N::AcceptLanguage's uninitialized-value warnings (RT 74338) | |||||
| 529 | local $SIG{__WARN__} = sub { | |||||
| 530 | 2 | 48 | warn $_[0] unless $_[0] =~ /^Use of uninitialized value/; | |||
| 531 | 143 | 372 | }; | |||
| 532 | 143 | 469 | my $i18n = I18N::AcceptLanguage->new(debug => $self->{_debug}, strict => 1); | |||
| 533 | 143 | 14242 | my $l = $i18n->accepts($http_accept_language, $self->{_supported}); | |||
| 534 | 143 | 10227 | local $SIG{__WARN__} = 'DEFAULT'; | |||
| 535 | ||||||
| 536 | # I18N-AcceptLanguage strict mode can return a sublanguage variant when | |||||
| 537 | # the request contains a sublanguage we don't support; force a retry. | |||||
| 538 | 143 | 842 | if($l && ($http_accept_language =~ /-/) && ($http_accept_language !~ qr/$l/i)) { | |||
| 539 | 3 | 5 | $self->_debug('Forcing fallback'); | |||
| 540 | 3 | 53 | undef $l; | |||
| 541 | } | |||||
| 542 | ||||||
| 543 | 143 | 130 | my $requested_sublanguage; | |||
| 544 | 143 | 148 | if(!$l) { | |||
| 545 | # Sort tokens by q-value once; both scan passes share the ordered list | |||||
| 546 | 28 | 51 | my $sorted = $self->_sorted_tokens($http_accept_language); | |||
| 547 | # First fallback: scan for xx-yy pairs, try base language xx | |||||
| 548 | 28 | 47 | ($l, $requested_sublanguage) = | |||
| 549 | $self->_scan_sublanguage_pairs($i18n, $sorted); | |||||
| 550 | 28 | 47 | if(!$l) { | |||
| 551 | # Second fallback: scan plain tokens without sublanguages | |||||
| 552 | 24 | 45 | $l = $self->_scan_plain_tokens($i18n, $sorted); | |||
| 553 | 24 | 39 | undef $requested_sublanguage if $l; | |||
| 554 | } | |||||
| 555 | } | |||||
| 556 | ||||||
| 557 | 143 | 643 | return ($l, $requested_sublanguage); | |||
| 558 | } | |||||
| 559 | ||||||
| 560 | # ââ _sorted_tokens ââââââââââââââââââââââââââââââââââââââââââââââââââââââââ | |||||
| 561 | # Purpose: Parse an Accept-Language header into tokens sorted by | |||||
| 562 | # descending quality value so fallback scans honour q= priority. | |||||
| 563 | # Entry: $header â validated Accept-Language string. | |||||
| 564 | # Exit: Arrayref of [$language_tag, $quality] pairs, highest q first. | |||||
| 565 | # Side Effects: None. | |||||
| 566 | sub _sorted_tokens | |||||
| 567 | { | |||||
| 568 | 36 | 280 | my ($self, $header) = @_; | |||
| 569 | 36 | 26 | my @tokens; | |||
| 570 | 36 | 55 | for my $token (split /,/, $header) { | |||
| 571 | 53 | 127 | $token =~ s/^\s+|\s+$//g; | |||
| 572 | 53 | 39 | my $q = 1.0; | |||
| 573 | 53 | 97 | if($token =~ s/;\s*q\s*=\s*(\d+(?:\.\d+)?)//) { | |||
| 574 | 17 | 29 | $q = $1 + 0; | |||
| 575 | } | |||||
| 576 | 53 | 94 | $token =~ s/^\s+|\s+$//g; | |||
| 577 | 53 | 92 | push @tokens, [$token, $q] if length $token; | |||
| 578 | } | |||||
| 579 | 36 21 | 62 41 | return [sort { $b->[1] <=> $a->[1] } @tokens]; | |||
| 580 | } | |||||
| 581 | ||||||
| 582 | # ââ _scan_sublanguage_pairs âââââââââââââââââââââââââââââââââââââââââââââââ | |||||
| 583 | # Purpose: Walk q-sorted tokens looking for xx-yy pairs; try accepting | |||||
| 584 | # the base language xx from the supported list. | |||||
| 585 | # Entry: $i18n â I18N::AcceptLanguage instance; | |||||
| 586 | # $sorted â arrayref from _sorted_tokens. | |||||
| 587 | # Exit: ($matched_code, $sublanguage_code) or (undef, undef). | |||||
| 588 | # Side Effects: Debug logging. | |||||
| 589 | sub _scan_sublanguage_pairs | |||||
| 590 | { | |||||
| 591 | 30 | 54 | my ($self, $i18n, $sorted) = @_; | |||
| 592 | ||||||
| 593 | 30 | 47 | $self->_debug(__PACKAGE__, ': ', __LINE__, ': scan q-sorted tokens for xx-yy pairs'); | |||
| 594 | 30 30 | 894 44 | for my $entry (@{$sorted}) { | |||
| 595 | 39 39 | 176 37 | my ($tag) = @{$entry}; | |||
| 596 | 39 | 72 | next unless $tag =~ /^(..)-(..)$/; | |||
| 597 | 13 | 17 | my ($base, $sub) = ($1, $2); | |||
| 598 | 13 | 39 | $self->_debug(__PACKAGE__, ': ', __LINE__, ": see if $base is supported"); | |||
| 599 | 13 | 299 | if($i18n->accepts($base, $self->{_supported})) { | |||
| 600 | 5 | 192 | $self->_debug("Fallback to $base as sublanguage $sub is not supported"); | |||
| 601 | 5 | 92 | return ($base, $sub); | |||
| 602 | } | |||||
| 603 | } | |||||
| 604 | 25 | 92 | return (undef, undef); | |||
| 605 | } | |||||
| 606 | ||||||
| 607 | # ââ _scan_plain_tokens ââââââââââââââââââââââââââââââââââââââââââââââââââââ | |||||
| 608 | # Purpose: Walk q-sorted tokens that have no sublanguage suffix and try | |||||
| 609 | # accepting each against the supported list. | |||||
| 610 | # Entry: $i18n â I18N::AcceptLanguage instance; | |||||
| 611 | # $sorted â arrayref from _sorted_tokens. | |||||
| 612 | # Exit: Matched code string, or undef. | |||||
| 613 | # Side Effects: Debug logging. | |||||
| 614 | sub _scan_plain_tokens | |||||
| 615 | { | |||||
| 616 | 27 | 26 | my ($self, $i18n, $sorted) = @_; | |||
| 617 | ||||||
| 618 | 27 | 40 | $self->_debug(__PACKAGE__, ': ', __LINE__, ': scan q-sorted tokens for plain alternatives'); | |||
| 619 | 27 27 | 798 42 | for my $entry (@{$sorted}) { | |||
| 620 | 35 35 | 89 33 | my ($tag) = @{$entry}; | |||
| 621 | 35 | 50 | next if $tag =~ /^..-../; # already tried in the pair scan | |||
| 622 | 29 | 46 | $self->_debug(__PACKAGE__, ': ', __LINE__, ": see if $tag is supported"); | |||
| 623 | 29 | 850 | if($i18n->accepts($tag, $self->{_supported})) { | |||
| 624 | 3 | 32 | $self->_debug("Fallback to $tag as best alternative"); | |||
| 625 | 3 | 75 | return $tag; | |||
| 626 | } | |||||
| 627 | } | |||||
| 628 | 24 | 788 | return undef; | |||
| 629 | } | |||||
| 630 | ||||||
| 631 | # ââ _resolve_match ââââââââââââââââââââââââââââââââââââââââââââââââââââââââ | |||||
| 632 | # Purpose: Given a matched code $l (possibly xx or xx-yy), populate all | |||||
| 633 | # of _slanguage, _rlanguage, _sublanguage and their code fields. | |||||
| 634 | # Entry: $l â 2-char or xx-yy language code; $requested_sublanguage â | |||||
| 635 | # 2-char variety code or undef; $http_accept_language â full header. | |||||
| 636 | # Exit: Returns true (1) if the caller should return immediately. | |||||
| 637 | # Side Effects: Mutates $self->{_slanguage}, _rlanguage, _sublanguage, etc. | |||||
| 638 | sub _resolve_match | |||||
| 639 | { | |||||
| 640 | 121 | 161 | my ($self, $l, $requested_sublanguage, $http_accept_language) = @_; | |||
| 641 | ||||||
| 642 | 121 | 170 | $self->_debug("l: $l"); | |||
| 643 | ||||||
| 644 | 121 | 3799 | if($l !~ /^..-../) { | |||
| 645 | # Base-language match (e.g. 'en') â no sublanguage component | |||||
| 646 | 76 | 121 | return $self->_resolve_base_match($l, $requested_sublanguage, $http_accept_language); | |||
| 647 | } elsif($l =~ /(.+)-(..)$/) { | |||||
| 648 | # Sublanguage match (e.g. 'en-gb') â resolve both language and variant | |||||
| 649 | 45 | 98 | return $self->_resolve_sublanguage_match($l, $1, $2, $http_accept_language); | |||
| 650 | } | |||||
| 651 | 0 | 0 | return 0; | |||
| 652 | } | |||||
| 653 | ||||||
| 654 | # ââ _resolve_base_match âââââââââââââââââââââââââââââââââââââââââââââââââââ | |||||
| 655 | # Purpose: Handle the case where a base-language code matched (no hyphen). | |||||
| 656 | # Sets _slanguage, _rlanguage; appends sublanguage name to rlanguage | |||||
| 657 | # when the client requested one we don't support. | |||||
| 658 | # Entry: $l â 2-char code; $requested_sublanguage â optional; $header. | |||||
| 659 | # Exit: 1 to signal caller should return, 0 otherwise. | |||||
| 660 | # Side Effects: Mutates slanguage, rlanguage, slanguage_code_alpha2. | |||||
| 661 | sub _resolve_base_match | |||||
| 662 | { | |||||
| 663 | 78 | 108 | my ($self, $l, $requested_sublanguage, $header) = @_; | |||
| 664 | ||||||
| 665 | 78 | 113 | $self->{_slanguage} = $self->_code2language($l); | |||
| 666 | 78 | 270132 | return 0 unless $self->{_slanguage}; | |||
| 667 | ||||||
| 668 | 74 | 156 | $self->_debug("_slanguage: $self->{_slanguage}"); | |||
| 669 | 74 | 2300 | $self->{_slanguage_code_alpha2} = $l; | |||
| 670 | 74 | 75 | $self->{_rlanguage} = $self->{_slanguage}; | |||
| 671 | ||||||
| 672 | # Attempt to name the sublanguage the client actually asked for | |||||
| 673 | 74 | 56 | my $sl; | |||
| 674 | 74 | 156 | if($header =~ /..-(..)$/) { | |||
| 675 | 8 | 29 | $self->_debug($1); | |||
| 676 | 8 | 200 | $sl = $self->_code2country($1); | |||
| 677 | 8 | 22 | $requested_sublanguage //= $1; | |||
| 678 | } elsif($header =~ /..-([a-z]{2,3})$/i) { | |||||
| 679 | 1 1 | 1 2 | eval { $sl = Locale::Object::Country->new(code_alpha3 => $1) }; | |||
| 680 | 1 | 266 | $self->_info($@) if $@; | |||
| 681 | } | |||||
| 682 | ||||||
| 683 | 74 | 107 | if($sl) { | |||
| 684 | 7 | 15 | $self->{_rlanguage} .= ' (' . $sl->name() . ')'; | |||
| 685 | } elsif($requested_sublanguage) { | |||||
| 686 | 4 | 8 | if(my $c = $self->_code2countryname($requested_sublanguage)) { | |||
| 687 | 2 | 14 | $self->{_rlanguage} .= " ($c)"; | |||
| 688 | } else { | |||||
| 689 | 2 | 3 | $self->{_rlanguage} .= " (Unknown: $requested_sublanguage)"; | |||
| 690 | } | |||||
| 691 | } | |||||
| 692 | 74 | 165 | return 1; | |||
| 693 | } | |||||
| 694 | ||||||
| 695 | # ââ _resolve_sublanguage_match ââââââââââââââââââââââââââââââââââââââââââââ | |||||
| 696 | # Purpose: Handle the case where the full xx-yy code matched in the | |||||
| 697 | # supported list. Resolves the variety name and caches results. | |||||
| 698 | # Entry: $l â full code e.g. 'en-gb'; $alpha2 â 'en'; $variety â 'gb'; | |||||
| 699 | # $header â full Accept-Language value. | |||||
| 700 | # Exit: 1 to signal caller should return, 0 otherwise. | |||||
| 701 | # Side Effects: Mutates _slanguage, _rlanguage, _sublanguage and code fields; | |||||
| 702 | # writes to cache. | |||||
| 703 | sub _resolve_sublanguage_match | |||||
| 704 | { | |||||
| 705 | 45 | 92 | my ($self, $l, $alpha2, $variety, $header) = @_; | |||
| 706 | ||||||
| 707 | 45 | 68 | my $i18n = I18N::AcceptLanguage->new(strict => 1); | |||
| 708 | 45 | 531 | my $accepts = $i18n->accepts($l, $self->{_supported}); | |||
| 709 | 45 | 1766 | $self->_debug("accepts = $accepts"); | |||
| 710 | ||||||
| 711 | 45 | 1244 | if($accepts) { | |||
| 712 | 45 | 70 | $self->_debug("accepts: $accepts"); | |||
| 713 | ||||||
| 714 | 45 | 1160 | if($accepts =~ /\-/) { | |||
| 715 | 45 | 52 | delete $self->{_slanguage}; | |||
| 716 | } else { | |||||
| 717 | # Cache look-up for the base-language name | |||||
| 718 | 0 | 0 | my $from_cache; | |||
| 719 | 0 | 0 | if($self->{_cache}) { | |||
| 720 | 0 | 0 | $from_cache = $self->{_cache}->get($CACHE_NS . "accepts:$accepts"); | |||
| 721 | } | |||||
| 722 | 0 | 0 | my $slanguage; | |||
| 723 | 0 | 0 | if($from_cache) { | |||
| 724 | 0 | 0 | $self->_debug("$accepts is in cache as $from_cache"); | |||
| 725 | 0 | 0 | $slanguage = (split(/=/, $from_cache))[0]; | |||
| 726 | } else { | |||||
| 727 | 0 | 0 | $slanguage = $self->_code2language($accepts); | |||
| 728 | } | |||||
| 729 | ||||||
| 730 | 0 | 0 | if($slanguage) { | |||
| 731 | 0 | 0 | $self->{_slanguage} = $slanguage; | |||
| 732 | ||||||
| 733 | # Normalise deprecated en-uk variety | |||||
| 734 | 0 | 0 | if($variety eq 'uk') { | |||
| 735 | 0 | 0 | $self->_warn({ warning => "Resetting country code to GB for $header" }); | |||
| 736 | 0 | 0 | $variety = 'gb'; | |||
| 737 | } | |||||
| 738 | ||||||
| 739 | 0 | 0 | if(defined(my $c = $self->_code2countryname($variety))) { | |||
| 740 | 0 | 0 | $self->_debug(__PACKAGE__, ': ', __LINE__, ": setting sublanguage to $c"); | |||
| 741 | 0 | 0 | $self->{_sublanguage} = $c; | |||
| 742 | } | |||||
| 743 | 0 | 0 | $self->{_slanguage_code_alpha2} = $accepts; | |||
| 744 | 0 | 0 | $self->{_sublanguage_code_alpha2} = $variety; | |||
| 745 | ||||||
| 746 | 0 | 0 | if($self->{_sublanguage}) { | |||
| 747 | 0 | 0 | $self->{_rlanguage} = "$self->{_slanguage} ($self->{_sublanguage})"; | |||
| 748 | 0 | 0 | $self->_debug(__PACKAGE__, ': ', __LINE__, ": _rlanguage: $self->{_rlanguage}"); | |||
| 749 | } | |||||
| 750 | ||||||
| 751 | 0 | 0 | unless($from_cache) { | |||
| 752 | 0 | 0 | $self->_debug("Set $variety to $slanguage=$accepts"); | |||
| 753 | $self->{_cache}->set( | |||||
| 754 | $CACHE_NS . "accepts:$variety", | |||||
| 755 | "$slanguage=$accepts", | |||||
| 756 | $CACHE_TTL_LONG | |||||
| 757 | 0 | 0 | ) if $self->{_cache}; | |||
| 758 | } | |||||
| 759 | 0 | 0 | return 1; | |||
| 760 | } | |||||
| 761 | } | |||||
| 762 | } | |||||
| 763 | ||||||
| 764 | # Accepts returned something but we couldn't resolve a language name â | |||||
| 765 | # try harder using the variety code directly | |||||
| 766 | 45 | 2118 | $self->{_rlanguage} = $self->_code2language($alpha2); | |||
| 767 | 45 | 357754 | $self->_debug("_rlanguage: $self->{_rlanguage}"); | |||
| 768 | ||||||
| 769 | 45 | 1386 | return 0 unless $accepts; | |||
| 770 | ||||||
| 771 | 45 | 67 | $self->_debug("http_accept_language = $header"); | |||
| 772 | 45 | 1167 | $l =~ /(..)-(..)/; | |||
| 773 | 45 | 80 | $variety = lc($2); | |||
| 774 | ||||||
| 775 | # Skip numeric/region codes like en-029 | |||||
| 776 | 45 | 138 | if(($variety =~ /[a-z]{2,3}/) && !defined($self->{_sublanguage})) { | |||
| 777 | 45 | 103 | $self->_get_closest($alpha2, $alpha2); | |||
| 778 | 45 | 78 | $self->_debug("Find the country code for $variety"); | |||
| 779 | ||||||
| 780 | 45 | 1160 | if($variety eq 'uk') { | |||
| 781 | 0 | 0 | $self->_warn({ warning => "Resetting country code to GB for $header" }); | |||
| 782 | 0 | 0 | $variety = 'gb'; | |||
| 783 | } | |||||
| 784 | ||||||
| 785 | 45 | 39 | my ($from_cache, $language_name); | |||
| 786 | 45 | 58 | if($self->{_cache}) { | |||
| 787 | 8 | 14 | $from_cache = $self->{_cache}->get($CACHE_NS . "variety:$variety"); | |||
| 788 | } | |||||
| 789 | ||||||
| 790 | 45 | 440 | if(defined($from_cache)) { | |||
| 791 | 4 | 8 | $self->_debug("$variety is in cache as $from_cache"); | |||
| 792 | # Cache stores "countryname=langcode" (e.g. "United Kingdom=en"). | |||||
| 793 | # Splitting on = gives the country name as the first field. | |||||
| 794 | 4 | 84 | ($language_name) = split(/=/, $from_cache); | |||
| 795 | } else { | |||||
| 796 | 41 | 147 | my $db = Locale::Object::DB->new(); | |||
| 797 | 41 41 | 74094 80 | my @results = @{$db->lookup( | |||
| 798 | table => 'country', | |||||
| 799 | result_column => 'name', | |||||
| 800 | search_column => 'code_alpha2', | |||||
| 801 | value => $variety | |||||
| 802 | )}; | |||||
| 803 | 41 | 5051 | if(defined($results[0])) { | |||
| 804 | 40 40 | 35 70 | eval { $language_name = $self->_code2countryname($variety) }; | |||
| 805 | } else { | |||||
| 806 | 1 | 2 | $self->_debug("Can't find the country code for $variety in Locale::Object::DB"); | |||
| 807 | } | |||||
| 808 | } | |||||
| 809 | ||||||
| 810 | 45 | 299 | if($@ || !defined($language_name)) { | |||
| 811 | 1 | 2 | $self->_warn({ warning => $@ }) if $@; | |||
| 812 | 1 | 3 | $self->_debug(__PACKAGE__, ': ', __LINE__, ': setting sublanguage to Unknown'); | |||
| 813 | 1 | 28 | $self->{_sublanguage} = 'Unknown'; | |||
| 814 | 1 | 3 | $self->_warn({ warning => "Can't determine values for $header" }); | |||
| 815 | } else { | |||||
| 816 | 44 | 56 | $self->{_sublanguage} = $language_name; | |||
| 817 | 44 | 72 | $self->_debug('variety name ', $self->{_sublanguage}); | |||
| 818 | 44 | 1299 | if($self->{_cache} && !defined($from_cache)) { | |||
| 819 | # Store "countryname=langcode" so future cache hits return the country | |||||
| 820 | # name in the first field. Previously this stored the language name | |||||
| 821 | # ("English=en" for en-gb) which was wrong â the cache-hit branch | |||||
| 822 | # split on = and used the first field as the sublanguage (country) name. | |||||
| 823 | 4 | 8 | $self->_debug("Set variety:$variety to $language_name=$self->{_slanguage_code_alpha2}"); | |||
| 824 | $self->{_cache}->set( | |||||
| 825 | 4 | 86 | $CACHE_NS . "variety:$variety", | |||
| 826 | "$language_name=$self->{_slanguage_code_alpha2}", | |||||
| 827 | $CACHE_TTL_LONG | |||||
| 828 | ); | |||||
| 829 | } | |||||
| 830 | } | |||||
| 831 | } | |||||
| 832 | ||||||
| 833 | 45 | 497 | if(defined($self->{_sublanguage})) { | |||
| 834 | 45 | 68 | $self->{_rlanguage} = "$self->{_slanguage} ($self->{_sublanguage})"; | |||
| 835 | 45 | 49 | $self->{_sublanguage_code_alpha2} = $variety; | |||
| 836 | 45 | 140 | return 1; | |||
| 837 | } | |||||
| 838 | 0 | 0 | return 0; | |||
| 839 | } | |||||
| 840 | ||||||
| 841 | # ââ _find_language_from_ip ââââââââââââââââââââââââââââââââââââââââââââââââ | |||||
| 842 | # Purpose: Fall back to the visitor's IP country when the Accept-Language | |||||
| 843 | # header produced no usable match. Looks up the official language | |||||
| 844 | # of the country and checks it against the supported list. | |||||
| 845 | # Entry: $http_accept_language â may be undef if no header was present. | |||||
| 846 | # Exit: Mutates _slanguage, _rlanguage via _get_closest if a match found. | |||||
| 847 | # Side Effects: Calls country(); may write to cache. | |||||
| 848 | sub _find_language_from_ip | |||||
| 849 | { | |||||
| 850 | 46 | 55 | my ($self, $http_accept_language) = @_; | |||
| 851 | ||||||
| 852 | 46 | 72 | my $country = $self->country(); | |||
| 853 | ||||||
| 854 | # If country() returned nothing, try to derive from the LANG env var | |||||
| 855 | 46 | 88 | if(!defined($country) && (my $c = $self->_what_language())) { | |||
| 856 | 25 | 78 | if($c =~ /^(..)_(..)/) { | |||
| 857 | 2 | 4 | $country = $2; | |||
| 858 | } elsif($c =~ /^(..)$/) { | |||||
| 859 | 14 | 19 | $country = $1; | |||
| 860 | } | |||||
| 861 | } | |||||
| 862 | 46 | 69 | return unless defined $country; | |||
| 863 | ||||||
| 864 | 20 | 37 | $self->_debug("country: $country"); | |||
| 865 | ||||||
| 866 | 20 | 641 | my ($language_name, $language_code2, $from_cache); | |||
| 867 | 20 | 28 | if($self->{_cache}) { | |||
| 868 | 2 | 4 | $from_cache = $self->{_cache}->get($CACHE_NS . 'language_name:' . $country); | |||
| 869 | } | |||||
| 870 | ||||||
| 871 | 20 | 137 | if($from_cache) { | |||
| 872 | 1 | 3 | $self->_debug("$country is in cache as $from_cache"); | |||
| 873 | 1 | 33 | ($language_name, $language_code2) = split(/=/, $from_cache); | |||
| 874 | } else { | |||||
| 875 | 19 | 48 | my $l = $self->_code2country(uc($country)); | |||
| 876 | 19 | 37 | if($l) { | |||
| 877 | 12 | 28 | $l = ($l->languages_official)[0]; | |||
| 878 | 12 | 5758 | if(defined $l) { | |||
| 879 | 12 | 21 | $language_name = $l->name; | |||
| 880 | 12 | 47 | $language_code2 = $l->code_alpha2; | |||
| 881 | 12 | 62 | $self->_debug("Official language: $language_name") if $language_name; | |||
| 882 | } | |||||
| 883 | } | |||||
| 884 | } | |||||
| 885 | ||||||
| 886 | 20 | 465 | my $ip = $ENV{'REMOTE_ADDR'}; | |||
| 887 | 20 | 41 | return unless $language_name; | |||
| 888 | ||||||
| 889 | 13 | 41 | if((!defined($self->{_rlanguage})) || ($self->{_rlanguage} eq 'Unknown')) { | |||
| 890 | 6 | 7 | $self->{_rlanguage} = $language_name; | |||
| 891 | } | |||||
| 892 | ||||||
| 893 | 13 | 46 | unless((exists $self->{_slanguage}) && ($self->{_slanguage} ne 'Unknown')) { | |||
| 894 | 13 | 11 | my $code; | |||
| 895 | ||||||
| 896 | 13 | 46 | if($language_name && $language_code2 && !defined($http_accept_language)) { | |||
| 897 | # Fast-path for search engines that hit with no Accept-Language | |||||
| 898 | 4 | 5 | $self->_debug("Fast assign to $language_code2"); | |||
| 899 | 4 | 136 | $code = $language_code2; | |||
| 900 | } else { | |||||
| 901 | 9 | 23 | $self->_debug("Call language2code on $self->{_rlanguage}"); | |||
| 902 | 9 | 286 | $code = Locale::Language::language2code($self->{_rlanguage}); | |||
| 903 | ||||||
| 904 | 9 | 92523 | unless($code) { | |||
| 905 | 0 | 0 | if($http_accept_language && ($http_accept_language ne $self->{_rlanguage})) { | |||
| 906 | 0 | 0 | $self->_debug("Call language2code on $http_accept_language"); | |||
| 907 | 0 | 0 | $code = Locale::Language::language2code($http_accept_language); | |||
| 908 | } | |||||
| 909 | 0 | 0 | unless($code) { | |||
| 910 | # Norwegian (Nynorsk) â strip the parenthetical qualifier | |||||
| 911 | 0 | 0 | if($self->{_rlanguage} =~ /(.+)\s\(.+/) { | |||
| 912 | 0 | 0 | if((!defined($http_accept_language)) || ($1 ne $self->{_rlanguage})) { | |||
| 913 | 0 | 0 | $self->_debug("Call language2code on $1"); | |||
| 914 | 0 | 0 | $code = Locale::Language::language2code($1); | |||
| 915 | } | |||||
| 916 | } | |||||
| 917 | 0 | 0 | unless($code) { | |||
| 918 | 0 | 0 | $self->_warn({ | |||
| 919 | warning => "Can't determine code from IP $ip for requested language $self->{_rlanguage}" | |||||
| 920 | }); | |||||
| 921 | } | |||||
| 922 | } | |||||
| 923 | } | |||||
| 924 | } | |||||
| 925 | ||||||
| 926 | 13 | 19 | if($code) { | |||
| 927 | 13 | 30 | $self->_get_closest($code, $language_code2); | |||
| 928 | 13 | 18 | unless($self->{_slanguage}) { | |||
| 929 | 0 | 0 | $self->_warn({ | |||
| 930 | warning => "Couldn't determine closest language for $language_name in $self->{_supported}" | |||||
| 931 | }); | |||||
| 932 | } else { | |||||
| 933 | 13 | 26 | $self->_debug("language set to $self->{_slanguage}, code set to $code"); | |||
| 934 | } | |||||
| 935 | } | |||||
| 936 | } | |||||
| 937 | ||||||
| 938 | 13 | 494 | if(!defined($self->{_slanguage_code_alpha2})) { | |||
| 939 | 8 | 10 | $self->_debug("Can't determine slanguage_code_alpha2"); | |||
| 940 | } elsif(!defined($from_cache) && $self->{_cache} && defined($self->{_slanguage_code_alpha2})) { | |||||
| 941 | 1 | 3 | $self->_debug("Set $country to $language_name=$self->{_slanguage_code_alpha2}"); | |||
| 942 | $self->{_cache}->set( | |||||
| 943 | 1 | 30 | $CACHE_NS . 'language_name:' . $country, | |||
| 944 | "$language_name=$self->{_slanguage_code_alpha2}", | |||||
| 945 | $CACHE_TTL_LONG | |||||
| 946 | ); | |||||
| 947 | } | |||||
| 948 | } | |||||
| 949 | ||||||
| 950 | # ââ _get_closest âââââââââââââââââââââââââââââââââââââââââââââââââââââââââ | |||||
| 951 | # Purpose: If $language_string matches the base language of any supported | |||||
| 952 | # entry, set _slanguage and _slanguage_code_alpha2. | |||||
| 953 | # Entry: $language_string â base code e.g. 'en'; $alpha2 â same or variant. | |||||
| 954 | # Exit: Mutates _slanguage and _slanguage_code_alpha2 on match. | |||||
| 955 | sub _get_closest | |||||
| 956 | { | |||||
| 957 | 63 | 112 | my ($self, $language_string, $alpha2) = @_; | |||
| 958 | ||||||
| 959 | # Map each supported entry to its base language code | |||||
| 960 | my %base_languages = | |||||
| 961 | 63 152 63 | 52 296 72 | map { /^(.+)-/ ? ($1 => $_) : ($_ => $_) } @{$self->{_supported}}; | |||
| 962 | ||||||
| 963 | 63 | 99 | if(exists $base_languages{$language_string}) { | |||
| 964 | 53 | 80 | $self->{_slanguage} = $self->{_rlanguage}; | |||
| 965 | 53 | 81 | $self->{_slanguage_code_alpha2} = $alpha2; | |||
| 966 | } | |||||
| 967 | } | |||||
| 968 | ||||||
| 969 | # ââ _what_language ââââââââââââââââââââââââââââââââââââââââââââââââââââââââ | |||||
| 970 | # Purpose: Return the raw (validated, untainted) Accept-Language string, | |||||
| 971 | # consulting in priority order: cached value, CGI lang= param, | |||||
| 972 | # HTTP_ACCEPT_LANGUAGE env var, LANG env var (local/debug mode). | |||||
| 973 | # Entry: May be called as a class method (no $self->{...} access) or | |||||
| 974 | # as an object method. | |||||
| 975 | # Exit: A validated language string, or undef if nothing available. | |||||
| 976 | # Side Effects: Caches result in $self->{_what_language} on object calls. | |||||
| 977 | sub _what_language { | |||||
| 978 | 286 | 2842 | my $self = $_[0]; | |||
| 979 | ||||||
| 980 | 286 | 319 | if(ref($self)) { | |||
| 981 | 217 | 218 | $self->_trace('Entered _what_language'); | |||
| 982 | 217 | 6503 | if($self->{_what_language}) { | |||
| 983 | 27 | 42 | $self->_trace('_what_language: returning cached value: ', $self->{_what_language}); | |||
| 984 | 27 | 840 | return $self->{_what_language}; | |||
| 985 | } | |||||
| 986 | 190 | 240 | if(my $info = $self->{_info}) { | |||
| 987 | 2 | 4 | if(my $rc = $info->lang()) { | |||
| 988 | 2 | 8 | $self->_trace("_what_language set language to $rc from the lang argument"); | |||
| 989 | 2 | 60 | return $self->{_what_language} = $rc; | |||
| 990 | } | |||||
| 991 | } | |||||
| 992 | } | |||||
| 993 | ||||||
| 994 | 257 | 362 | if(my $raw_lang = $ENV{'HTTP_ACCEPT_LANGUAGE'}) { | |||
| 995 | # Validate and untaint â RFC 7231 §5.3.5 character set plus * wildcard | |||||
| 996 | 214 | 526 | if($raw_lang =~ /^([A-Za-z0-9\-,;=.*\s]{1,$ACCEPT_LANG_MAX})$/a) { | |||
| 997 | 190 | 1203 | my $rc = $1; # untainted | |||
| 998 | 190 | 205 | if(ref($self)) { | |||
| 999 | 142 | 280 | return $self->{_what_language} = $rc; | |||
| 1000 | } | |||||
| 1001 | 48 | 88 | return $rc; | |||
| 1002 | } elsif(ref($self)) { | |||||
| 1003 | 24 | 122 | $self->_warn({ warning => 'HTTP_ACCEPT_LANGUAGE contains invalid characters; ignoring' }); | |||
| 1004 | } | |||||
| 1005 | } | |||||
| 1006 | ||||||
| 1007 | 67 | 619 | if(defined($ENV{'LANG'})) { | |||
| 1008 | # Running locally (debug mode) â derive from system locale. | |||||
| 1009 | # Apply the same untainting discipline as HTTP_ACCEPT_LANGUAGE: only | |||||
| 1010 | # alphanumeric, hyphen, underscore, and dot are legitimate in a POSIX | |||||
| 1011 | # locale name (e.g. "en_US.UTF-8", "de_DE", "ja"). Anything else is | |||||
| 1012 | # either malformed or an injection attempt; discard it silently. | |||||
| 1013 | 9 | 24 | if($ENV{'LANG'} =~ /^([A-Za-z0-9_.\-]{1,$ACCEPT_LANG_MAX})$/a) { | |||
| 1014 | 5 | 127 | my $rc = $1; # untainted | |||
| 1015 | 5 | 8 | if(ref($self)) { | |||
| 1016 | 5 | 13 | return $self->{_what_language} = $rc; | |||
| 1017 | } | |||||
| 1018 | 0 | 0 | return $rc; | |||
| 1019 | } elsif(ref($self)) { | |||||
| 1020 | 4 | 56 | $self->_warn({ warning => 'LANG contains invalid characters; ignoring' }); | |||
| 1021 | } | |||||
| 1022 | } | |||||
| 1023 | 62 | 708 | return; | |||
| 1024 | } | |||||
| 1025 | ||||||
| 1026 - 1051 | =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. =head3 API SPECIFICATION Input: none beyond $self Returns: Str (2 lowercase chars) | undef 'Unknown' is only returned in the Baidu-EU special case via _handle_eu_country. =head3 MESSAGES "GEOIP_COUNTRY_CODE contains an invalid country code; ignoring" "HTTP_CF_IPCOUNTRY contains an invalid country code; ignoring" "X.X.X.X isn't a valid IP address" "Can't determine country from LAN connection X" "Can't determine country from loopback connection X" "cache contains a numeric country: N" "IP matches to a numeric country" =cut | |||||
| 1052 | ||||||
| 1053 | sub country { | |||||
| 1054 | 144 | 2672 | my $self = shift; | |||
| 1055 | ||||||
| 1056 | 144 | 206 | $self->_trace(__PACKAGE__, ': Entered country()'); | |||
| 1057 | ||||||
| 1058 | # Return cached result immediately (but see FIXME below about undef caching) | |||||
| 1059 | 144 | 5444 | if($self->{_country}) { | |||
| 1060 | 7 | 13 | $self->_trace('quick return: ', $self->{_country}); | |||
| 1061 | 7 | 224 | return $self->{_country}; | |||
| 1062 | } | |||||
| 1063 | ||||||
| 1064 | # mod_geoip: validate against ISO 3166-1 alpha-2 before trusting | |||||
| 1065 | 137 | 177 | if(defined($ENV{'GEOIP_COUNTRY_CODE'})) { | |||
| 1066 | 16 | 39 | if($ENV{'GEOIP_COUNTRY_CODE'} =~ /^([A-Z]{2})$/a) { | |||
| 1067 | 9 | 18 | $self->{_country} = lc($1); | |||
| 1068 | 9 | 16 | return $self->{_country}; | |||
| 1069 | } else { | |||||
| 1070 | 7 | 12 | $self->_warn({ warning => 'GEOIP_COUNTRY_CODE contains an invalid country code; ignoring' }); | |||
| 1071 | } | |||||
| 1072 | } | |||||
| 1073 | ||||||
| 1074 | # Cloudflare: 'XX' means Cloudflare couldn't determine country â skip it | |||||
| 1075 | 128 | 436 | if(($ENV{'HTTP_CF_IPCOUNTRY'}) && ($ENV{'HTTP_CF_IPCOUNTRY'} ne 'XX')) { | |||
| 1076 | 8 | 24 | if($ENV{'HTTP_CF_IPCOUNTRY'} =~ /^([A-Z]{2})$/a) { | |||
| 1077 | 5 | 11 | $self->{_country} = lc($1); | |||
| 1078 | 5 | 15 | return $self->{_country}; | |||
| 1079 | } else { | |||||
| 1080 | 3 | 8 | $self->_warn({ warning => 'HTTP_CF_IPCOUNTRY contains an invalid country code; ignoring' }); | |||
| 1081 | } | |||||
| 1082 | } | |||||
| 1083 | ||||||
| 1084 | 123 | 119 | my $raw_ip = $ENV{'REMOTE_ADDR'}; | |||
| 1085 | 123 | 170 | return unless defined $raw_ip; | |||
| 1086 | ||||||
| 1087 | # Validate and untaint the IP address before passing to any geo module | |||||
| 1088 | 89 | 48 | my $ip; | |||
| 1089 | 89 | 259 | if($raw_ip =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/a) { | |||
| 1090 | 79 | 79 | $ip = $1; # untainted IPv4 | |||
| 1091 | } elsif($raw_ip =~ /^([0-9a-fA-F:]{2,39}|[0-9a-fA-F:]{2,30}:(?:\d{1,3}\.){3}\d{1,3})$/a) { | |||||
| 1092 | 3 | 5 | $ip = $1; # untainted IPv6, including mixed notation (e.g. ::ffff:192.0.2.1) | |||
| 1093 | } else { | |||||
| 1094 | 7 | 17 | $self->_warn({ warning => "$raw_ip isn't a valid IP address" }); | |||
| 1095 | 7 | 258 | return; | |||
| 1096 | } | |||||
| 1097 | ||||||
| 1098 | 82 | 1557 | require Data::Validate::IP; | |||
| 1099 | 82 | 88600 | Data::Validate::IP->import(); | |||
| 1100 | ||||||
| 1101 | 82 | 121 | if(!is_ipv4($ip)) { | |||
| 1102 | 4 | 35 | $self->_debug("$ip isn't IPv4. Is it IPv6?"); | |||
| 1103 | 4 | 159 | if($ip eq '::1') { | |||
| 1104 | 3 | 6 | $ip = '127.0.0.1'; # normalise loopback | |||
| 1105 | } elsif($ip =~ /^::ffff:(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/i) { | |||||
| 1106 | 0 | 0 | $ip = $1; # normalise IPv4-mapped IPv6 (::ffff:a.b.c.d) to plain IPv4 | |||
| 1107 | } elsif(!is_ipv6($ip)) { | |||||
| 1108 | 1 | 10 | $self->_warn({ warning => "$ip isn't a valid IP address" }); | |||
| 1109 | 1 | 2 | return; | |||
| 1110 | } | |||||
| 1111 | } | |||||
| 1112 | 81 | 1591 | if(is_private_ip($ip)) { | |||
| 1113 | 2 | 71 | $self->_debug("Can't determine country from LAN connection $ip"); | |||
| 1114 | 2 | 67 | return; | |||
| 1115 | } | |||||
| 1116 | 79 | 4821 | if(is_loopback_ip($ip)) { | |||
| 1117 | 40 | 1285 | $self->_debug("Can't determine country from loopback connection $ip"); | |||
| 1118 | 40 | 1422 | return; | |||
| 1119 | } | |||||
| 1120 | ||||||
| 1121 | # Cache look-up â skip for LAN/loopback (already returned above) | |||||
| 1122 | 39 | 1873 | if($self->{_cache}) { | |||
| 1123 | 13 | 26 | $self->{_country} = $self->{_cache}->get($CACHE_NS . "country:$ip"); | |||
| 1124 | 13 | 612 | if(defined($self->{_country})) { | |||
| 1125 | 5 | 7 | if($self->{_country} !~ /\D/) { | |||
| 1126 | 4 | 11 | $self->_warn({ warning => 'cache contains a numeric country: ' . $self->{_country} }); | |||
| 1127 | 4 | 129 | $self->{_cache}->remove($CACHE_NS . "country:$ip"); | |||
| 1128 | 4 | 151 | delete $self->{_country}; | |||
| 1129 | } else { | |||||
| 1130 | 1 | 2 | $self->_debug("Get $ip from cache = $self->{_country}"); | |||
| 1131 | 1 | 32 | return $self->{_country}; | |||
| 1132 | } | |||||
| 1133 | } | |||||
| 1134 | 12 | 22 | $self->_debug("$ip isn't in the cache"); | |||
| 1135 | } | |||||
| 1136 | ||||||
| 1137 | # Try IP::Country first (fastest, local database) | |||||
| 1138 | 38 | 454 | if($self->{_have_ipcountry} == $GEO_UNKNOWN) { | |||
| 1139 | 1 1 | 3 42 | if(eval { require IP::Country }) { | |||
| 1140 | 0 | 0 | IP::Country->import(); | |||
| 1141 | 0 | 0 | $self->{_have_ipcountry} = $GEO_PRESENT; | |||
| 1142 | 0 | 0 | $self->{_ipcountry} = IP::Country::Fast->new(); | |||
| 1143 | } else { | |||||
| 1144 | 1 | 162 | $self->{_have_ipcountry} = $GEO_ABSENT; | |||
| 1145 | } | |||||
| 1146 | } | |||||
| 1147 | 38 | 140 | $self->_debug("have_ipcountry $self->{_have_ipcountry}"); | |||
| 1148 | ||||||
| 1149 | 38 | 1213 | if($self->{_have_ipcountry}) { | |||
| 1150 | 25 | 45 | $self->{_country} = $self->{_ipcountry}->inet_atocc($ip); | |||
| 1151 | 25 | 48 | if($self->{_country}) { | |||
| 1152 | 23 | 49 | $self->{_country} = lc($self->{_country}); | |||
| 1153 | } elsif(is_ipv4($ip)) { | |||||
| 1154 | 2 | 15 | $self->_debug("$ip is not known by IP::Country"); | |||
| 1155 | } | |||||
| 1156 | } | |||||
| 1157 | ||||||
| 1158 | # Try Geo::IP if IP::Country gave nothing | |||||
| 1159 | 38 | 103 | unless(defined($self->{_country})) { | |||
| 1160 | 14 | 17 | if($self->{_have_geoip} == $GEO_UNKNOWN) { | |||
| 1161 | 1 | 3 | $self->_load_geoip(); | |||
| 1162 | } | |||||
| 1163 | 14 | 40 | if($self->{_have_geoip} == $GEO_PRESENT) { | |||
| 1164 | 1 | 4 | $self->{_country} = $self->{_geoip}->country_code_by_addr($ip); | |||
| 1165 | } | |||||
| 1166 | ||||||
| 1167 | # Geo::IPfree has a known-broken entry for $BROKEN_GEOIPFREE | |||||
| 1168 | 14 | 56 | if(!defined($self->{_country}) && ($ip ne $BROKEN_GEOIPFREE)) { | |||
| 1169 | 13 | 39 | if($self->{_have_geoipfree} == $GEO_UNKNOWN) { | |||
| 1170 | 0 0 | 0 0 | eval { require Geo::IPfree }; | |||
| 1171 | 0 | 0 | unless($@) { | |||
| 1172 | 0 | 0 | Geo::IPfree::IP->import(); | |||
| 1173 | 0 | 0 | $self->{_have_geoipfree} = $GEO_PRESENT; | |||
| 1174 | 0 | 0 | $self->{_geoipfree} = Geo::IPfree->new(); | |||
| 1175 | } else { | |||||
| 1176 | 0 | 0 | $self->{_have_geoipfree} = $GEO_ABSENT; | |||
| 1177 | } | |||||
| 1178 | } | |||||
| 1179 | 13 | 32 | if($self->{_have_geoipfree} == $GEO_PRESENT) { | |||
| 1180 | 1 | 5 | if(my $country = ($self->{_geoipfree}->LookUp($ip))[0]) { | |||
| 1181 | 1 | 4 | $self->{_country} = lc($country); | |||
| 1182 | } | |||||
| 1183 | } | |||||
| 1184 | } | |||||
| 1185 | } | |||||
| 1186 | ||||||
| 1187 | # 'eu' is not a real country â discard | |||||
| 1188 | 38 | 97 | if($self->{_country} && ($self->{_country} eq 'eu')) { | |||
| 1189 | 2 | 3 | delete $self->{_country}; | |||
| 1190 | } | |||||
| 1191 | ||||||
| 1192 | # Remote JSON lookup via geoplugin | |||||
| 1193 | 38 | 57 | if((!$self->{_country}) && | |||
| 1194 | 15 0 | 736 0 | (eval { require LWP::Simple::WithCache; require JSON::Parse })) { | |||
| 1195 | 0 | 0 | $self->_debug("Look up $ip on geoplugin"); | |||
| 1196 | 0 | 0 | LWP::Simple::WithCache->import(); | |||
| 1197 | 0 | 0 | JSON::Parse->import(); | |||
| 1198 | ||||||
| 1199 | 0 | 0 | if(my $data = LWP::Simple::WithCache::get("http://www.geoplugin.net/json.gp?ip=$ip")) { | |||
| 1200 | 0 0 | 0 0 | eval { $self->{_country} = JSON::Parse::parse_json($data)->{'geoplugin_countryCode'} }; | |||
| 1201 | 0 | 0 | $self->_warn({ warning => "geoplugin returned unparseable JSON: $@" }) if $@; | |||
| 1202 | } | |||||
| 1203 | } | |||||
| 1204 | ||||||
| 1205 | # Last resort: Whois | |||||
| 1206 | 38 | 147 | unless($self->{_country}) { | |||
| 1207 | 15 | 28 | $self->_resolve_country_via_whois($ip); | |||
| 1208 | } | |||||
| 1209 | ||||||
| 1210 | # Sanitise and normalise whatever we found | |||||
| 1211 | 38 | 53 | if($self->{_country}) { | |||
| 1212 | 25 | 48 | if($self->{_country} !~ /\D/) { | |||
| 1213 | 2 | 6 | $self->_warn({ warning => 'IP matches to a numeric country' }); | |||
| 1214 | 2 | 135 | delete $self->{_country}; | |||
| 1215 | } else { | |||||
| 1216 | 23 | 28 | $self->{_country} = lc($self->{_country}); | |||
| 1217 | ||||||
| 1218 | # Legacy mappings | |||||
| 1219 | 23 | 37 | if($self->{_country} eq 'hk') { | |||
| 1220 | 3 | 4 | $self->{_country} = 'cn'; # HK is no longer a separate country in Whois | |||
| 1221 | } elsif($self->{_country} eq 'eu') { | |||||
| 1222 | 2 | 4 | $self->_handle_eu_country($ip); | |||
| 1223 | } | |||||
| 1224 | ||||||
| 1225 | 23 | 93 | if($self->{_country} && ($self->{_country} !~ /\D/)) { | |||
| 1226 | 0 | 0 | $self->_warn({ warning => "cache contains a numeric country: $self->{_country}" }); | |||
| 1227 | 0 | 0 | delete $self->{_country}; | |||
| 1228 | } elsif($self->{_country} && $self->{_cache}) { | |||||
| 1229 | 7 | 13 | $self->_debug("Set $ip to $self->{_country}"); | |||
| 1230 | $self->{_cache}->set( | |||||
| 1231 | $CACHE_NS . "country:$ip", | |||||
| 1232 | $self->{_country}, | |||||
| 1233 | 7 | 207 | $CACHE_TTL_SHORT | |||
| 1234 | ); | |||||
| 1235 | } | |||||
| 1236 | } | |||||
| 1237 | } | |||||
| 1238 | ||||||
| 1239 | 38 | 1071 | return $self->{_country}; | |||
| 1240 | } | |||||
| 1241 | ||||||
| 1242 | # ââ _resolve_country_via_whois âââââââââââââââââââââââââââââââââââââââââââââ | |||||
| 1243 | # Purpose: Attempt Net::Whois::IP then Net::Whois::IANA as a last resort. | |||||
| 1244 | # Entry: $ip â validated, untainted IP string. | |||||
| 1245 | # Exit: Sets $self->{_country} if a result was found. | |||||
| 1246 | # Side Effects: Network I/O; logs debug messages. | |||||
| 1247 | sub _resolve_country_via_whois | |||||
| 1248 | { | |||||
| 1249 | 12 | 148 | my ($self, $ip) = @_; | |||
| 1250 | ||||||
| 1251 | 12 | 51 | $self->_debug("Look up $ip on Whois"); | |||
| 1252 | ||||||
| 1253 | 12 | 563 | require Net::Whois::IP; | |||
| 1254 | 12 | 201 | Net::Whois::IP->import(); | |||
| 1255 | ||||||
| 1256 | 12 | 6 | my $whois; | |||
| 1257 | 12 | 16 | eval { | |||
| 1258 | # Catch connection timeouts by converting Carp::carp into a die | |||||
| 1259 | 12 1 | 50 25 | local $SIG{__WARN__} = sub { die $_[0] }; | |||
| 1260 | 12 | 16 | $whois = Net::Whois::IP::whoisip_query($ip); | |||
| 1261 | }; | |||||
| 1262 | ||||||
| 1263 | 12 | 59 | unless($@ || !defined($whois) || (ref($whois) ne 'HASH')) { | |||
| 1264 | 9 | 10 | if(defined($whois->{Country})) { | |||
| 1265 | 8 | 19 | $self->{_country} = $whois->{Country}; | |||
| 1266 | } elsif(defined($whois->{country})) { | |||||
| 1267 | 1 | 3 | $self->{_country} = $whois->{country}; | |||
| 1268 | } | |||||
| 1269 | 9 | 9 | if($self->{_country}) { | |||
| 1270 | 9 | 23 | if($self->{_country} eq 'EU') { | |||
| 1271 | 2 | 3 | delete $self->{_country}; | |||
| 1272 | } elsif(($self->{_country} eq 'US') && defined($whois->{'StateProv'}) && ($whois->{'StateProv'} eq 'PR')) { | |||||
| 1273 | # RT#131347: Puerto Rico is not the US | |||||
| 1274 | 1 | 1 | $self->{_country} = 'pr'; | |||
| 1275 | } | |||||
| 1276 | } | |||||
| 1277 | } | |||||
| 1278 | ||||||
| 1279 | 12 | 23 | if($self->{_country}) { | |||
| 1280 | 7 | 13 | $self->_debug("Found $ip on Net::Whois::IP as ", $self->{_country}); | |||
| 1281 | # Strip carriage returns (e.g. 190.24.1.122) and trailing comments | |||||
| 1282 | 7 | 224 | $self->{_country} =~ s/[\r\n]//g; | |||
| 1283 | 7 | 13 | if($self->{_country} =~ /^(..)\s*#/) { | |||
| 1284 | 2 | 3 | $self->{_country} = $1; | |||
| 1285 | } | |||||
| 1286 | 7 | 10 | return; | |||
| 1287 | } | |||||
| 1288 | ||||||
| 1289 | 5 | 9 | $self->_debug("Look up $ip on IANA"); | |||
| 1290 | ||||||
| 1291 | 5 | 161 | require Net::Whois::IANA; | |||
| 1292 | 5 | 187 | Net::Whois::IANA->import(); | |||
| 1293 | ||||||
| 1294 | 5 | 8 | my $iana = Net::Whois::IANA->new(); | |||
| 1295 | 5 5 | 9 7 | eval { $iana->whois_query(-ip => $ip) }; | |||
| 1296 | 5 | 12 | unless($@) { | |||
| 1297 | 5 | 7 | $self->{_country} = $iana->country(); | |||
| 1298 | 5 | 13 | $self->_debug("IANA reports $ip as ", $self->{_country}); | |||
| 1299 | } | |||||
| 1300 | ||||||
| 1301 | 5 | 156 | if($self->{_country}) { | |||
| 1302 | 4 | 6 | $self->{_country} =~ s/[\r\n]//g; | |||
| 1303 | 4 | 10 | if($self->{_country} =~ /^(..)\s*#/) { | |||
| 1304 | 2 | 3 | $self->{_country} = $1; | |||
| 1305 | } | |||||
| 1306 | } | |||||
| 1307 | } | |||||
| 1308 | ||||||
| 1309 | # ââ _handle_eu_country ââââââââââââââââââââââââââââââââââââââââââââââââââââ | |||||
| 1310 | # Purpose: Resolve the ambiguous 'eu' country code. RT-86809 shows that | |||||
| 1311 | # Baidu reports itself as EU when it is actually in CN. All | |||||
| 1312 | # other 'eu' addresses are logged as Unknown. | |||||
| 1313 | # Entry: $ip â validated, untainted IP string. | |||||
| 1314 | # Exit: Sets $self->{_country} to 'cn' or 'Unknown'. | |||||
| 1315 | # Side Effects: Loads Net::Subnet; writes info log entry. | |||||
| 1316 | sub _handle_eu_country | |||||
| 1317 | { | |||||
| 1318 | 4 | 23 | my ($self, $ip) = @_; | |||
| 1319 | ||||||
| 1320 | 4 | 485 | require Net::Subnet; | |||
| 1321 | 4 | 2024 | Net::Subnet->import(); | |||
| 1322 | ||||||
| 1323 | 4 | 8 | if(subnet_matcher($BAIDU_SUBNET)->($ip)) { | |||
| 1324 | 2 | 73 | $self->{_country} = 'cn'; | |||
| 1325 | } else { | |||||
| 1326 | 2 | 45 | $self->_info("$ip has country of eu"); | |||
| 1327 | 2 | 85 | $self->{_country} = 'Unknown'; | |||
| 1328 | } | |||||
| 1329 | } | |||||
| 1330 | ||||||
| 1331 | # ââ _load_geoip âââââââââââââââââââââââââââââââââââââââââââââââââââââââââââ | |||||
| 1332 | # Purpose: Probe for the Geo::IP database file and the Geo::IP module; | |||||
| 1333 | # set _have_geoip and initialise _geoip on success. | |||||
| 1334 | # Entry: _have_geoip must be GEO_UNKNOWN. | |||||
| 1335 | # Exit: _have_geoip set to GEO_PRESENT or GEO_ABSENT. | |||||
| 1336 | # Side Effects: Requires Geo::IP; opens GeoIP.dat. | |||||
| 1337 | sub _load_geoip | |||||
| 1338 | { | |||||
| 1339 | 3 | 23 | my $self = shift; | |||
| 1340 | ||||||
| 1341 | # Check for the database file before even trying to load the module | |||||
| 1342 | # (avoids noisy errors on Windows â CPANTESTERS report 54117bd0) | |||||
| 1343 | 3 | 52 | my $db_present = ( | |||
| 1344 | (($^O eq 'MSWin32') && (-r 'c:/GeoIP/GeoIP.dat')) | |||||
| 1345 | || (-r '/usr/local/share/GeoIP/GeoIP.dat') | |||||
| 1346 | || (-r '/usr/share/GeoIP/GeoIP.dat') | |||||
| 1347 | ); | |||||
| 1348 | ||||||
| 1349 | 3 | 6 | unless($db_present) { | |||
| 1350 | 3 | 4 | $self->{_have_geoip} = $GEO_ABSENT; | |||
| 1351 | 3 | 9 | return; | |||
| 1352 | } | |||||
| 1353 | ||||||
| 1354 | 0 0 | 0 0 | eval { require Geo::IP }; | |||
| 1355 | 0 | 0 | if($@) { | |||
| 1356 | 0 | 0 | $self->{_have_geoip} = $GEO_ABSENT; | |||
| 1357 | 0 | 0 | return; | |||
| 1358 | } | |||||
| 1359 | ||||||
| 1360 | 0 | 0 | Geo::IP->import(); | |||
| 1361 | 0 | 0 | $self->{_have_geoip} = $GEO_PRESENT; | |||
| 1362 | ||||||
| 1363 | # GEOIP_STANDARD = 0 (can't use the constant name directly) | |||||
| 1364 | 0 | 0 | if(-r '/usr/share/GeoIP/GeoIP.dat') { | |||
| 1365 | 0 | 0 | $self->{_geoip} = Geo::IP->open('/usr/share/GeoIP/GeoIP.dat', 0); | |||
| 1366 | } else { | |||||
| 1367 | 0 | 0 | $self->{_geoip} = Geo::IP->new(0); | |||
| 1368 | } | |||||
| 1369 | } | |||||
| 1370 | ||||||
| 1371 - 1386 | =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. =head3 API SPECIFICATION Input: none beyond $self Returns: Locale::Object::Country | undef =cut | |||||
| 1387 | ||||||
| 1388 | sub locale { | |||||
| 1389 | 19 | 550 | my $self = shift; | |||
| 1390 | ||||||
| 1391 | 19 | 36 | return $self->{_locale} if $self->{_locale}; | |||
| 1392 | ||||||
| 1393 | 17 | 17 | my $agent = $ENV{'HTTP_USER_AGENT'}; | |||
| 1394 | ||||||
| 1395 | # First try: parse the language tag from the User-Agent parenthetical | |||||
| 1396 | 17 | 46 | if(defined($agent) && ($agent =~ /\((.+)\)/)) { | |||
| 1397 | 6 | 16 | foreach(split(/;/, $1)) { | |||
| 1398 | 15 | 11 | my $candidate = $_; | |||
| 1399 | 15 | 34 | $candidate =~ s/^\s+|\s+$//g; # trim both ends | |||
| 1400 | ||||||
| 1401 | 15 | 23 | if($candidate =~ /^[a-zA-Z]{2}-([a-zA-Z]{2})$/) { | |||
| 1402 | 2 | 5 | local $SIG{__WARN__} = undef; | |||
| 1403 | 2 | 4 | if(my $c = $self->_code2country($1)) { | |||
| 1404 | 2 | 3 | $self->{_locale} = $c; | |||
| 1405 | 2 | 6 | return $c; | |||
| 1406 | } | |||||
| 1407 | } | |||||
| 1408 | } | |||||
| 1409 | ||||||
| 1410 | # Second try: HTTP::BrowserDetect (works for more User-Agents) | |||||
| 1411 | 4 4 | 4 440 | if(eval { require HTTP::BrowserDetect }) { | |||
| 1412 | 4 | 7998 | HTTP::BrowserDetect->import(); | |||
| 1413 | 4 | 11 | my $browser = HTTP::BrowserDetect->new($agent); | |||
| 1414 | 4 | 432 | if($browser && $browser->country() && (my $c = $self->_code2country($browser->country()))) { | |||
| 1415 | 1 | 2 | $self->{_locale} = $c; | |||
| 1416 | 1 | 7 | return $c; | |||
| 1417 | } | |||||
| 1418 | } | |||||
| 1419 | } | |||||
| 1420 | ||||||
| 1421 | # Third try: IP address | |||||
| 1422 | 14 | 115 | my $country = $self->country(); | |||
| 1423 | 14 | 22 | if($country) { | |||
| 1424 | 8 | 13 | $country =~ s/[\r\n]//g; | |||
| 1425 | 8 | 6 | my $c; | |||
| 1426 | 8 | 8 | eval { | |||
| 1427 | 8 0 | 24 0 | local $SIG{__WARN__} = sub { die $_[0] }; | |||
| 1428 | 8 | 16 | $c = $self->_code2country($country); | |||
| 1429 | }; | |||||
| 1430 | 8 | 16 | unless($@) { | |||
| 1431 | 8 | 12 | if($c) { | |||
| 1432 | 8 | 8 | $self->{_locale} = $c; | |||
| 1433 | 8 | 14 | return $c; | |||
| 1434 | } | |||||
| 1435 | } | |||||
| 1436 | } | |||||
| 1437 | ||||||
| 1438 | # Fourth try: mod_geoip env var â apply the same ISO 3166-1 validation | |||||
| 1439 | # used in country() to guard against spoofed or malformed values | |||||
| 1440 | 6 | 10 | if(defined($ENV{'GEOIP_COUNTRY_CODE'})) { | |||
| 1441 | 2 | 4 | if($ENV{'GEOIP_COUNTRY_CODE'} =~ /^([A-Z]{2})$/a) { | |||
| 1442 | 0 | 0 | if(my $c = $self->_code2country(lc($1))) { | |||
| 1443 | 0 | 0 | $self->{_locale} = $c; | |||
| 1444 | 0 | 0 | return $c; | |||
| 1445 | } | |||||
| 1446 | } | |||||
| 1447 | } | |||||
| 1448 | 6 | 7 | return undef; | |||
| 1449 | } | |||||
| 1450 | ||||||
| 1451 - 1469 | =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> =head3 API SPECIFICATION Input: none beyond $self Returns: Str (IANA timezone name) | undef =head3 MESSAGES "Couldn't determine the timezone" "LWP::Simple::WithCache and LWP::Simple are both absent; cannot contact ip-api.com" Returns undef rather than croaking; install either LWP variant to enable ip-api lookups. =cut | |||||
| 1470 | ||||||
| 1471 | sub time_zone { | |||||
| 1472 | 12 | 739 | my $self = shift; | |||
| 1473 | ||||||
| 1474 | 12 | 21 | $self->_trace('Entered time_zone'); | |||
| 1475 | ||||||
| 1476 | 11 | 469 | if($self->{_timezone}) { | |||
| 1477 | 3 | 7 | $self->_trace('quick return: ', $self->{_timezone}); | |||
| 1478 | 3 | 91 | return $self->{_timezone}; | |||
| 1479 | } | |||||
| 1480 | ||||||
| 1481 | 8 | 11 | my $raw_ip = $ENV{'REMOTE_ADDR'}; | |||
| 1482 | ||||||
| 1483 | 8 | 9 | if(defined $raw_ip) { | |||
| 1484 | # Untaint before any external use â kept in sync with country()'s pattern, | |||||
| 1485 | # including the mixed-notation branch for ::ffff:a.b.c.d addresses. | |||||
| 1486 | 6 | 6 | my $ip; | |||
| 1487 | 6 | 22 | if($raw_ip =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/a) { | |||
| 1488 | 4 | 5 | $ip = $1; | |||
| 1489 | } elsif($raw_ip =~ /^([0-9a-fA-F:]{2,39}|[0-9a-fA-F:]{2,30}:(?:\d{1,3}\.){3}\d{1,3})$/a) { | |||||
| 1490 | 0 | 0 | $ip = $1; | |||
| 1491 | } else { | |||||
| 1492 | 2 | 6 | $self->_warn({ warning => "$raw_ip isn't a valid IP address" }); | |||
| 1493 | 2 | 6 | return; | |||
| 1494 | } | |||||
| 1495 | ||||||
| 1496 | 4 | 6 | if($self->{_have_geoip} == $GEO_UNKNOWN) { | |||
| 1497 | 1 | 6 | $self->_load_geoip(); | |||
| 1498 | } | |||||
| 1499 | 4 | 10 | if($self->{_have_geoip} == $GEO_PRESENT) { | |||
| 1500 | 1 1 | 3 1 | eval { $self->{_timezone} = $self->{_geoip}->time_zone($ip) }; | |||
| 1501 | } | |||||
| 1502 | ||||||
| 1503 | 4 | 11 | unless($self->{_timezone}) { | |||
| 1504 | 3 3 0 | 2 169 0 | if(eval { require LWP::Simple::WithCache; require JSON::Parse }) { | |||
| 1505 | 0 | 0 | $self->_debug("Look up $ip on ip-api.com"); | |||
| 1506 | 0 | 0 | LWP::Simple::WithCache->import(); | |||
| 1507 | 0 | 0 | JSON::Parse->import(); | |||
| 1508 | ||||||
| 1509 | 0 | 0 | if(my $data = LWP::Simple::WithCache::get("http://ip-api.com/json/$ip")) { | |||
| 1510 | 0 0 | 0 0 | eval { $self->{_timezone} = JSON::Parse::parse_json($data)->{'timezone'} }; | |||
| 1511 | 0 | 0 | $self->_warn({ warning => "ip-api.com returned unparseable JSON: $@" }) if $@; | |||
| 1512 | } | |||||
| 1513 | 3 0 | 132 0 | } elsif(eval { require LWP::Simple; require JSON::Parse }) { | |||
| 1514 | 0 | 0 | $self->_debug("Look up $ip on ip-api.com"); | |||
| 1515 | 0 | 0 | LWP::Simple->import(); | |||
| 1516 | 0 | 0 | JSON::Parse->import(); | |||
| 1517 | ||||||
| 1518 | 0 | 0 | if(my $data = LWP::Simple::get("http://ip-api.com/json/$ip")) { | |||
| 1519 | 0 0 | 0 0 | eval { $self->{_timezone} = JSON::Parse::parse_json($data)->{'timezone'} }; | |||
| 1520 | 0 | 0 | $self->_warn({ warning => "ip-api.com returned unparseable JSON: $@" }) if $@; | |||
| 1521 | } | |||||
| 1522 | } else { | |||||
| 1523 | # Neither LWP variant is available â degrade gracefully rather than | |||||
| 1524 | # killing the entire request with a croak; caller can check for undef. | |||||
| 1525 | 3 | 6 | $self->_warn({ warning => 'LWP::Simple::WithCache and LWP::Simple are both absent; cannot contact ip-api.com' }); | |||
| 1526 | } | |||||
| 1527 | } | |||||
| 1528 | } else { | |||||
| 1529 | # Local connection â read from /etc/timezone or DateTime::TimeZone | |||||
| 1530 | 2 | 52 | if(CORE::open(my $fin, '<', '/etc/timezone')) { | |||
| 1531 | 2 | 473 | my $tz = <$fin>; | |||
| 1532 | 2 | 3 | chomp $tz; | |||
| 1533 | 2 | 16 | $self->{_timezone} = $tz; | |||
| 1534 | } else { | |||||
| 1535 | 0 | 0 | $self->{_timezone} = DateTime::TimeZone::Local->TimeZone()->name(); | |||
| 1536 | } | |||||
| 1537 | } | |||||
| 1538 | ||||||
| 1539 | 6 | 440 | unless(defined($self->{_timezone})) { | |||
| 1540 | 3 | 5 | $self->_warn({ warning => "Couldn't determine the timezone" }); | |||
| 1541 | } | |||||
| 1542 | 6 | 208 | return $self->{_timezone}; | |||
| 1543 | } | |||||
| 1544 | ||||||
| 1545 - 1556 | =head2 is_rtl Returns true (1) if the negotiated language is written right-to-left, false (0) otherwise. Covers Arabic, Hebrew, Persian, Urdu, Yiddish, Dhivehi, Pashto, Sindhi, Uyghur, and Kurdish. =head3 API SPECIFICATION Input: none beyond $self Returns: 1 | 0 =cut | |||||
| 1557 | ||||||
| 1558 | sub is_rtl | |||||
| 1559 | { | |||||
| 1560 | 6 | 46 | my $self = shift; | |||
| 1561 | 6 | 8 | return $RTL_LANGS{$self->language_code_alpha2() // ''} ? 1 : 0; | |||
| 1562 | } | |||||
| 1563 | ||||||
| 1564 - 1574 | =head2 text_direction Returns C<'rtl'> or C<'ltr'> for the negotiated language, suitable for direct use as an HTML C<dir> attribute value. =head3 API SPECIFICATION Input: none beyond $self Returns: 'rtl' | 'ltr' =cut | |||||
| 1575 | ||||||
| 1576 | sub text_direction | |||||
| 1577 | { | |||||
| 1578 | 2 | 17 | my $self = shift; | |||
| 1579 | 2 | 3 | return $self->is_rtl() ? 'rtl' : 'ltr'; | |||
| 1580 | } | |||||
| 1581 | ||||||
| 1582 - 1600 | =head2 plural_category Returns the CLDR plural category for the integer C<$n> in the negotiated language. The returned string is one of C<'zero'>, C<'one'>, C<'two'>, C<'few'>, C<'many'>, or C<'other'>. Rules are embedded for ~70 languages including Arabic (6 forms), Slavic languages (3-4 forms), Celtic languages (up to 6 forms), and Hebrew, Maltese, Romanian, Latvian, Lithuanian, and Slovenian. Languages not in the table fall back to the English rule (n == 1 => C<'one'>, else C<'other'>). For fractional numbers or full CLDR v42+ accuracy, use C<Locale::CLDR>. =head3 API SPECIFICATION Input: $n - non-negative integer (fractional values are truncated) Returns: Str - one of zero/one/two/few/many/other =cut | |||||
| 1601 | ||||||
| 1602 | # CLDR plural category rules (https://unicode.org/cldr/charts/42/supplemental/language_plural_rules.html). | |||||
| 1603 | # Values are coderefs: ($n) â category string. Languages absent from this | |||||
| 1604 | # table fall back to the standard one/other rule inside plural_category(). | |||||
| 1605 | my %PLURAL_RULES = ( | |||||
| 1606 | ||||||
| 1607 | # ââ No plural distinction (always 'other') ââââââââââââââââââââââââââââ | |||||
| 1608 | (map { $_ => sub { 'other' } } | |||||
| 1609 | qw(az bm bo dz id ig ii in ja jbo jv jw kde kea km ko lkt lo ms | |||||
| 1610 | my nqo root sah ses sg th to vi wo yo zh)), | |||||
| 1611 | ||||||
| 1612 | # ââ Standard: n == 1 â 'one', else 'other' âââââââââââââââââââââââââââ | |||||
| 1613 | (map { $_ => sub { int($_[0]) == 1 ? 'one' : 'other' } } | |||||
| 1614 | qw(af an ast bg bn brx ca cgg da de el en eo es et eu fi | |||||
| 1615 | gl gsw gu ha haw hu ia it kcg kk kl lb lg mas ml mn mr | |||||
| 1616 | nb nd ne nl nn nyn om or pa pap rm rof rwk saq seh sn so | |||||
| 1617 | sq ss ssy st sv sw ta te teo tig tk tl tn ts ur wae xh xog)), | |||||
| 1618 | ||||||
| 1619 | # ââ French / Portuguese-BR: n ⤠1 â 'one' ââââââââââââââââââââââââââââ | |||||
| 1620 | (map { $_ => sub { int($_[0]) <= 1 ? 'one' : 'other' } } qw(fr pt_BR)), | |||||
| 1621 | ||||||
| 1622 | # ââ Arabic: zero/one/two/few/many/other âââââââââââââââââââââââââââââââ | |||||
| 1623 | ar => sub { | |||||
| 1624 | my $n = int($_[0]); | |||||
| 1625 | my $m100 = $n % 100; | |||||
| 1626 | return 'zero' if $n == 0; | |||||
| 1627 | return 'one' if $n == 1; | |||||
| 1628 | return 'two' if $n == 2; | |||||
| 1629 | return 'few' if $m100 >= 3 && $m100 <= 10; | |||||
| 1630 | return 'many' if $m100 >= 11 && $m100 <= 99; | |||||
| 1631 | return 'other'; | |||||
| 1632 | }, | |||||
| 1633 | ||||||
| 1634 | # ââ Hebrew: one/two/many/other ââââââââââââââââââââââââââââââââââââââââ | |||||
| 1635 | he => sub { | |||||
| 1636 | my $n = int($_[0]); | |||||
| 1637 | return 'one' if $n == 1; | |||||
| 1638 | return 'two' if $n == 2; | |||||
| 1639 | return 'many' if $n != 0 && $n % 10 == 0; | |||||
| 1640 | return 'other'; | |||||
| 1641 | }, | |||||
| 1642 | ||||||
| 1643 | # ââ Russian / Ukrainian / Belarusian: one/few/many ââââââââââââââââââââ | |||||
| 1644 | (map { $_ => sub { | |||||
| 1645 | my $n = int($_[0]); | |||||
| 1646 | my $m10 = $n % 10; | |||||
| 1647 | my $m100 = $n % 100; | |||||
| 1648 | return 'one' if $m10 == 1 && $m100 != 11; | |||||
| 1649 | return 'few' if $m10 >= 2 && $m10 <= 4 && ($m100 < 10 || $m100 >= 20); | |||||
| 1650 | return 'many'; | |||||
| 1651 | } } qw(ru uk be)), | |||||
| 1652 | ||||||
| 1653 | # ââ Polish: one/few/many ââââââââââââââââââââââââââââââââââââââââââââââ | |||||
| 1654 | pl => sub { | |||||
| 1655 | my $n = int($_[0]); | |||||
| 1656 | my $m10 = $n % 10; | |||||
| 1657 | my $m100 = $n % 100; | |||||
| 1658 | return 'one' if $n == 1; | |||||
| 1659 | return 'few' if $m10 >= 2 && $m10 <= 4 && ($m100 < 10 || $m100 >= 20); | |||||
| 1660 | return 'many'; | |||||
| 1661 | }, | |||||
| 1662 | ||||||
| 1663 | # ââ Czech / Slovak: one/few/other ââââââââââââââââââââââââââââââââââââ | |||||
| 1664 | (map { $_ => sub { | |||||
| 1665 | my $n = int($_[0]); | |||||
| 1666 | return 'one' if $n == 1; | |||||
| 1667 | return 'few' if $n >= 2 && $n <= 4; | |||||
| 1668 | return 'other'; | |||||
| 1669 | } } qw(cs sk)), | |||||
| 1670 | ||||||
| 1671 | # ââ Romanian: one/few/other âââââââââââââââââââââââââââââââââââââââââââ | |||||
| 1672 | ro => sub { | |||||
| 1673 | my $n = int($_[0]); | |||||
| 1674 | my $m100 = $n % 100; | |||||
| 1675 | return 'one' if $n == 1; | |||||
| 1676 | return 'few' if $n == 0 || ($m100 >= 1 && $m100 <= 19); | |||||
| 1677 | return 'other'; | |||||
| 1678 | }, | |||||
| 1679 | ||||||
| 1680 | # ââ Latvian: zero/one/other âââââââââââââââââââââââââââââââââââââââââââ | |||||
| 1681 | lv => sub { | |||||
| 1682 | my $n = int($_[0]); | |||||
| 1683 | my $m10 = $n % 10; | |||||
| 1684 | my $m100 = $n % 100; | |||||
| 1685 | return 'zero' if $m10 == 0 || ($m100 >= 11 && $m100 <= 19); | |||||
| 1686 | return 'one' if $m10 == 1 && $m100 != 11; | |||||
| 1687 | return 'other'; | |||||
| 1688 | }, | |||||
| 1689 | ||||||
| 1690 | # ââ Lithuanian: one/few/other âââââââââââââââââââââââââââââââââââââââââ | |||||
| 1691 | lt => sub { | |||||
| 1692 | my $n = int($_[0]); | |||||
| 1693 | my $m10 = $n % 10; | |||||
| 1694 | my $m100 = $n % 100; | |||||
| 1695 | return 'one' if $m10 == 1 && ($m100 < 10 || $m100 >= 20); | |||||
| 1696 | return 'few' if $m10 >= 2 && ($m100 < 10 || $m100 >= 20); | |||||
| 1697 | return 'other'; | |||||
| 1698 | }, | |||||
| 1699 | ||||||
| 1700 | # ââ Slovenian: one/two/few/other ââââââââââââââââââââââââââââââââââââââ | |||||
| 1701 | sl => sub { | |||||
| 1702 | my $m100 = int($_[0]) % 100; | |||||
| 1703 | return 'one' if $m100 == 1; | |||||
| 1704 | return 'two' if $m100 == 2; | |||||
| 1705 | return 'few' if $m100 == 3 || $m100 == 4; | |||||
| 1706 | return 'other'; | |||||
| 1707 | }, | |||||
| 1708 | ||||||
| 1709 | # ââ Welsh: zero/one/two/few/many/other âââââââââââââââââââââââââââââââ | |||||
| 1710 | cy => sub { | |||||
| 1711 | my $n = int($_[0]); | |||||
| 1712 | return 'zero' if $n == 0; | |||||
| 1713 | return 'one' if $n == 1; | |||||
| 1714 | return 'two' if $n == 2; | |||||
| 1715 | return 'few' if $n == 3; | |||||
| 1716 | return 'many' if $n == 6; | |||||
| 1717 | return 'other'; | |||||
| 1718 | }, | |||||
| 1719 | ||||||
| 1720 | # ââ Irish: one/two/few/many/other ââââââââââââââââââââââââââââââââââââ | |||||
| 1721 | ga => sub { | |||||
| 1722 | my $n = int($_[0]); | |||||
| 1723 | return 'one' if $n == 1; | |||||
| 1724 | return 'two' if $n == 2; | |||||
| 1725 | return 'few' if $n >= 3 && $n <= 6; | |||||
| 1726 | return 'many' if $n >= 7 && $n <= 10; | |||||
| 1727 | return 'other'; | |||||
| 1728 | }, | |||||
| 1729 | ||||||
| 1730 | # ââ Maltese: one/two/few/many/other ââââââââââââââââââââââââââââââââââ | |||||
| 1731 | mt => sub { | |||||
| 1732 | my $n = int($_[0]); | |||||
| 1733 | my $m100 = $n % 100; | |||||
| 1734 | return 'one' if $n == 1; | |||||
| 1735 | return 'two' if $n == 2; | |||||
| 1736 | return 'few' if $n == 0 || ($m100 >= 3 && $m100 <= 10); | |||||
| 1737 | return 'many' if $m100 >= 11 && $m100 <= 19; | |||||
| 1738 | return 'other'; | |||||
| 1739 | }, | |||||
| 1740 | ); | |||||
| 1741 | ||||||
| 1742 | sub plural_category | |||||
| 1743 | { | |||||
| 1744 | 16 | 69 | my ($self, $n) = @_; | |||
| 1745 | 16 | 13 | my $code = $self->language_code_alpha2() // return 'other'; | |||
| 1746 | 15 0 | 19 0 | my $rule = $PLURAL_RULES{$code} // sub { int($_[0]) == 1 ? 'one' : 'other' }; | |||
| 1747 | 15 | 13 | return $rule->($n); | |||
| 1748 | } | |||||
| 1749 | ||||||
| 1750 - 1778 | =head2 translation_file Returns the filesystem path to the best matching translation file for the negotiated language in the given directory. The lookup tries (in order): =over 4 =item 1. C<$dir/$lang-$sublang.$ext> (e.g. C<en-gb.json>) =item 2. C<$dir/$lang.$ext> (e.g. C<en.json>) =back Returns C<undef> if no matching file exists. =head3 API SPECIFICATION Input: $dir - Str path to the directory containing translation files $ext - Str file extension without leading dot (default: 'json') Returns: Str (absolute or relative path) | undef =head3 MESSAGES (none - returns undef silently when no file is found) =cut | |||||
| 1779 | ||||||
| 1780 | sub translation_file | |||||
| 1781 | { | |||||
| 1782 | 5 | 42 | my ($self, $dir, $ext) = @_; | |||
| 1783 | 5 | 7 | return unless defined $dir; | |||
| 1784 | 4 | 16 | $ext //= 'json'; | |||
| 1785 | 4 | 5 | $ext =~ s/^\.//; # accept '.json' or 'json' | |||
| 1786 | ||||||
| 1787 | 4 | 3 | my @candidates; | |||
| 1788 | 4 | 5 | if(my $sub = $self->sublanguage_code_alpha2()) { | |||
| 1789 | 0 | 0 | push @candidates, $self->language_code_alpha2() . '-' . $sub; | |||
| 1790 | } | |||||
| 1791 | 4 | 5 | push @candidates, $self->language_code_alpha2() | |||
| 1792 | if defined $self->language_code_alpha2(); | |||||
| 1793 | ||||||
| 1794 | 4 | 5 | for my $code (@candidates) { | |||
| 1795 | 4 | 4 | my $path = "$dir/$code.$ext"; | |||
| 1796 | 4 | 41 | return $path if -e $path; | |||
| 1797 | } | |||||
| 1798 | 1 | 2 | return; | |||
| 1799 | } | |||||
| 1800 | ||||||
| 1801 | # ââ _code2language ââââââââââââââââââââââââââââââââââââââââââââââââââââââââ | |||||
| 1802 | # Purpose: Translate a 2-char language code to its English name, with | |||||
| 1803 | # optional CHI caching. | |||||
| 1804 | # Entry: $code â 2-char ISO 639-1 code; must be defined and non-empty. | |||||
| 1805 | # Exit: Human-readable language name string, or undef. | |||||
| 1806 | # Side Effects: Reads/writes cache. | |||||
| 1807 | sub _code2language | |||||
| 1808 | { | |||||
| 1809 | 147 | 736 | my ($self, $code) = @_; | |||
| 1810 | ||||||
| 1811 | 147 | 158 | return unless $code; | |||
| 1812 | 145 | 156 | if(defined($self->{_country})) { | |||
| 1813 | 3 | 7 | $self->_debug("_code2language $code, country ", $self->{_country}); | |||
| 1814 | } else { | |||||
| 1815 | 142 | 161 | $self->_debug("_code2language $code"); | |||
| 1816 | } | |||||
| 1817 | ||||||
| 1818 | 145 | 4159 | unless($self->{_cache}) { | |||
| 1819 | 123 | 217 | return Locale::Language::code2language($code); | |||
| 1820 | } | |||||
| 1821 | ||||||
| 1822 | 22 | 46 | if(my $from_cache = $self->{_cache}->get($CACHE_NS . "code2language:$code")) { | |||
| 1823 | 7 | 592 | $self->_trace("_code2language found in cache $from_cache"); | |||
| 1824 | 7 | 132 | return $from_cache; | |||
| 1825 | } | |||||
| 1826 | ||||||
| 1827 | # Compute, cache, then return the value separately â | |||||
| 1828 | # CHI->set() is not guaranteed to return the stored value across all drivers | |||||
| 1829 | 15 | 642 | $self->_trace('_code2language not in cache, storing'); | |||
| 1830 | 15 | 441 | my $name = Locale::Language::code2language($code); | |||
| 1831 | 15 | 355839 | if(defined $name) { | |||
| 1832 | 14 | 44 | $self->{_cache}->set($CACHE_NS . "code2language:$code", $name, $CACHE_TTL_LONG); | |||
| 1833 | } | |||||
| 1834 | 15 | 2346 | return $name; | |||
| 1835 | } | |||||
| 1836 | ||||||
| 1837 | # ââ _code2country âââââââââââââââââââââââââââââââââââââââââââââââââââââââââ | |||||
| 1838 | # Purpose: Translate a 2-char country code to a Locale::Object::Country | |||||
| 1839 | # object, suppressing the expected "No result found" warning. | |||||
| 1840 | # Entry: $code â 2-char ISO 3166-1 alpha-2 code (any case). | |||||
| 1841 | # Exit: Locale::Object::Country object, or undef. | |||||
| 1842 | # Side Effects: None beyond the Locale::Object::Country look-up. | |||||
| 1843 | sub _code2country | |||||
| 1844 | { | |||||
| 1845 | 90 | 633 | my ($self, $code) = @_; | |||
| 1846 | ||||||
| 1847 | 90 | 106 | return unless $code; | |||
| 1848 | 88 | 108 | if($self->{_country}) { | |||
| 1849 | 13 | 20 | $self->_trace(">_code2country $code, country ", $self->{_country}); | |||
| 1850 | } else { | |||||
| 1851 | 75 | 100 | $self->_trace(">_code2country $code"); | |||
| 1852 | } | |||||
| 1853 | ||||||
| 1854 | 88 | 2522 | my $rc; | |||
| 1855 | { | |||||
| 1856 | # Scope the signal handler tightly â only suppress the one known-harmless warning | |||||
| 1857 | 88 | 66 | local $SIG{__WARN__} = sub { | |||
| 1858 | 14 | 78344 | warn $_[0] unless $_[0] =~ /No result found in country table/; | |||
| 1859 | 88 | 241 | }; | |||
| 1860 | 88 | 313 | $rc = Locale::Object::Country->new(code_alpha2 => $code); | |||
| 1861 | } | |||||
| 1862 | 88 | 2501931 | $self->_trace('<_code2country ', $code || 'undef'); | |||
| 1863 | 88 | 3279 | return $rc; | |||
| 1864 | } | |||||
| 1865 | ||||||
| 1866 | # ââ _code2countryname âââââââââââââââââââââââââââââââââââââââââââââââââââââ | |||||
| 1867 | # Purpose: Translate a 2-char country code to its English name string, | |||||
| 1868 | # with optional CHI caching. | |||||
| 1869 | # Entry: $code â 2-char ISO 3166-1 alpha-2 code. | |||||
| 1870 | # Exit: Country name string, or undef. | |||||
| 1871 | # Side Effects: Reads/writes cache. | |||||
| 1872 | sub _code2countryname | |||||
| 1873 | { | |||||
| 1874 | 51 | 335 | my ($self, $code) = @_; | |||
| 1875 | ||||||
| 1876 | 51 | 82 | return unless $code; | |||
| 1877 | 49 | 83 | $self->_trace(">_code2countryname $code"); | |||
| 1878 | ||||||
| 1879 | 49 | 1634 | unless($self->{_cache}) { | |||
| 1880 | 42 | 60 | my $country = $self->_code2country($code); | |||
| 1881 | 42 | 92 | return defined($country) ? $country->name : undef; | |||
| 1882 | } | |||||
| 1883 | ||||||
| 1884 | 7 | 16 | if(my $from_cache = $self->{_cache}->get($CACHE_NS . "code2countryname:$code")) { | |||
| 1885 | 1 | 74 | $self->_trace("_code2countryname found in cache $from_cache"); | |||
| 1886 | 1 | 32 | return $from_cache; | |||
| 1887 | } | |||||
| 1888 | ||||||
| 1889 | 6 | 253 | if(my $country = $self->_code2country($code)) { | |||
| 1890 | 5 | 11 | $self->_debug('_code2countryname not in cache, storing'); | |||
| 1891 | 5 | 120 | my $name = $country->name(); | |||
| 1892 | 5 | 41 | $self->_trace('<_code2countryname ', $name); | |||
| 1893 | # Store then return explicitly â don't rely on set() return value | |||||
| 1894 | 5 | 119 | $self->{_cache}->set($CACHE_NS . "code2countryname:$code", $name, $CACHE_TTL_LONG); | |||
| 1895 | 5 | 764 | return $name; | |||
| 1896 | } | |||||
| 1897 | 1 | 2 | $self->_trace('<_code2countryname undef'); | |||
| 1898 | 1 | 30 | return undef; | |||
| 1899 | } | |||||
| 1900 | ||||||
| 1901 | # ââ _log ââââââââââââââââââââââââââââââââââââââââââââââââââââââââââââââââââ | |||||
| 1902 | # Purpose: Append a message to $self->{messages} and forward to the | |||||
| 1903 | # optional logger object. | |||||
| 1904 | # Entry: $level â log level string (debug/info/notice/warn/trace/error); | |||||
| 1905 | # @messages â one or more strings to concatenate. | |||||
| 1906 | # Exit: void | |||||
| 1907 | # Side Effects: Mutates $self->{messages}; calls logger method if set. | |||||
| 1908 | sub _log | |||||
| 1909 | { | |||||
| 1910 | 2183 | 2895 | my ($self, $level, @messages) = @_; | |||
| 1911 | ||||||
| 1912 | 2183 | 2759 | return unless ref($self) && scalar(@messages); | |||
| 1913 | ||||||
| 1914 | 2181 | 2584 | my $text = join('', grep defined, @messages); | |||
| 1915 | 2181 | 1518 | return unless length($text); | |||
| 1916 | 2180 2180 | 1124 2535 | push @{$self->{'messages'}}, { level => $level, message => $text }; | |||
| 1917 | ||||||
| 1918 | 2180 | 2000 | if(my $logger = $self->{'logger'}) { | |||
| 1919 | 2178 | 2224 | $logger->$level($text); | |||
| 1920 | } | |||||
| 1921 | } | |||||
| 1922 | ||||||
| 1923 | 1121 1121 | 688 907 | sub _debug { my $self = shift; $self->_log('debug', @_) } | |||
| 1924 | 4 4 | 1031 9 | sub _info { my $self = shift; $self->_log('info', @_) } | |||
| 1925 | 4 4 | 869 8 | sub _notice { my $self = shift; $self->_log('notice', @_) } | |||
| 1926 | 1045 1045 | 1560 1042 | sub _trace { my $self = shift; $self->_log('trace', @_) } | |||
| 1927 | ||||||
| 1928 | # ââ _warn âââââââââââââââââââââââââââââââââââââââââââââââââââââââââââââââââ | |||||
| 1929 | # Purpose: Emit a warning through the logger (if set) or via Carp::carp. | |||||
| 1930 | # Entry: A single hashref argument: { warning => 'message text' }. | |||||
| 1931 | # All callers MUST use this structured form â plain-string calls | |||||
| 1932 | # silently lose the message when no logger is configured. | |||||
| 1933 | # Exit: void | |||||
| 1934 | # Side Effects: Calls logger->warn() or Carp::carp(). | |||||
| 1935 | sub _warn | |||||
| 1936 | { | |||||
| 1937 | 20 | 128 | my $self = shift; | |||
| 1938 | 20 | 29 | if(defined($self->{'logger'})) { | |||
| 1939 | # Logger gets the warning text as a plain string, not a data structure | |||||
| 1940 | 18 | 24 | my $params = Params::Get::get_params('warning', @_); | |||
| 1941 | 18 | 323 | $self->{'logger'}->warn($params->{'warning'} // join('', grep defined, @_)); | |||
| 1942 | } else { | |||||
| 1943 | 2 | 5 | my $params = Params::Get::get_params('warning', @_); | |||
| 1944 | 2 | 34 | my $msg = $params->{'warning'} // join('', grep defined, @_); | |||
| 1945 | 2 | 4 | $self->_log('warn', $msg); | |||
| 1946 | 2 | 2 | Carp::carp($msg); | |||
| 1947 | } | |||||
| 1948 | } | |||||
| 1949 | ||||||
| 1950 - 2124 | =head1 LIMITATIONS
=over 4
=item * B<is_rtl() covers primary-script RTL languages only>
C<is_rtl()> returns true for the 10 ISO 639-1 codes whose overwhelmingly
dominant script is right-to-left. Languages with script variants (e.g.
Azerbaijani C<az>, which uses Latin in modern Azerbaijan but Arabic in Iran)
are treated as LTR. If you serve content in multiple scripts of the same
language, inspect the sublanguage or Accept-Language header directly.
=item * B<plural_category() uses embedded CLDR rules, not Locale::CLDR>
The embedded rules cover ~70 languages and truncate fractional C<$n> to an
integer. For full CLDR v42 accuracy (including fractional forms and
languages not in the table) install and use C<Locale::CLDR> directly.
=item * B<Logger must be a blessed object>
The C<logger> parameter is documented as accepting a code ref, array ref, or
filename, but the current implementation calls C<< $logger->$level() >> and will
die on non-blessed values. Wrap alternative logger types in a
C<Log::Abstraction> instance before passing them to C<new()>.
=item * B<es-419 sublanguage returns undef>
Three-part regional codes such as C<es-419> (Latin American Spanish) do not
resolve to a C<sublanguage()> value because ISO 3166-1 does not define '419'.
This is a known limitation of the Locale::Object layer.
=item * B<Whois lookups are slow and unreliable>
Without C<IP::Country>, C<Geo::IP>, or C<Geo::IPfree> installed, C<country()>
falls back to Whois queries against live RIPE/ARIN/IANA servers. These can
time out under load. Install at least one local geo-database module and enable
the CHI cache to avoid this.
=item * B<Sub::Private not yet enforced>
The C<_*> private methods are currently accessible from outside the package.
C<Sub::Private> should be added to enforce encapsulation once white-box tests
are updated to call only the public API.
=item * B<IPv4-mapped IPv6 addresses are normalised to IPv4>
C<REMOTE_ADDR> values in the form C<::ffff:a.b.c.d> (RFC 4291 section 2.5.5)
are silently rewritten to the embedded C<a.b.c.d> IPv4 address before any
geo-lookup. This is correct for country detection purposes but means the raw
address string is not preserved in cache keys or log messages.
=item * B<EU country code is irresolvable (with one exception)>
IP addresses that Whois reports as country C<EU> are mapped to C<'Unknown'>
unless they fall within Baidu's known subnet (RT-86809). There is no ISO
3166-1 country code for the European Union.
=back
=head1 AUTHOR
Nigel Horne, C<< <njh at nigelhorne.com> >>
=head1 BUGS
Please report any bugs or feature requests to the author.
If C<HTTP_ACCEPT_LANGUAGE> contains a sub-tag with a 3-digit UN M.49 region
code (e.g. C<es-419> for Latin American Spanish), C<sublanguage()> returns
C<undef> because ISO 3166-1 does not define numeric codes.
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 * L<Test Dashboard|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::AcceptLanguage>
=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
=encoding utf-8
=head1 FORMAL SPECIFICATION
=head2 new
new : Class à Params â CGI::Lingua
â p : Params ⢠p.supported â â
â¹ result.language â (p.supported ⪠{'Unknown'})
=head2 language
language : CGI::Lingua â Str
result â {name(l) | l â supported} ⪠{'Unknown'}
=head2 is_rtl
is_rtl : CGI::Lingua â Bool
is_rtl(s) â language_code_alpha2(s) â RTL_LANGS
=head2 text_direction
text_direction : CGI::Lingua â {'rtl', 'ltr'}
text_direction(s) â is_rtl(s) ? 'rtl' : 'ltr'
=head2 plural_category
plural_category : CGI::Lingua à â â PluralCategory
plural_category(s, n) â PLURAL_RULES[language_code_alpha2(s)](n)
=head2 translation_file
translation_file : CGI::Lingua à Path à Ext â Path | undef
translation_file(s, d, e) â
first p â candidates(s) ⢠â file d/p.e
where candidates(s) = [lang(s)-sublang(s), lang(s)] \ {undef}
=head1 ACKNOWLEDGEMENTS
=head1 LICENSE AND COPYRIGHT
Copyright 2010-2026 Nigel Horne.
This program is released under the following licence: GPL2
=cut | |||||
| 2125 | ||||||
| 2126 | 1; # End of CGI::Lingua | |||||