CGI-Lingua
view release on metacpan or search on metacpan
lib/CGI/Lingua.pm view on Meta::CPAN
package CGI::Lingua;
use warnings;
use strict;
use autodie qw(:all);
use Carp qw(croak carp);
use Object::Configure 0.23;
use Params::Get 0.15; # 0.15 fast-path: unblessed hashref returned directly
use Readonly;
use Scalar::Util qw(blessed);
use JSON::PP ();
use Class::Autouse qw{
Locale::Language
Locale::Object::Country
Locale::Object::DB
I18N::AcceptLanguage
I18N::LangTags::Detect
};
our $VERSION = '0.85';
# ── Module-level constants ───────────────────────────────────────────────────
# Gathering magic strings here makes behavioural changes one-edit operations.
Readonly my $CACHE_TTL_LONG => '1 month';
Readonly my $CACHE_TTL_SHORT => '1 hour';
Readonly my $CACHE_NS => 'CGI::Lingua:'; # namespace prefix for every key
Readonly my $BROKEN_GEOIPFREE => '45.128.139.41'; # https://github.com/bricas/geo-ipfree/issues/10
Readonly my $BAIDU_SUBNET => '185.10.104.0/22';# RT-86809: Baidu misreports as EU
Readonly my $DEPRECATED_EN_UK => 'en-uk'; # some browsers still send this
Readonly my $CANONICAL_EN_GB => 'en-gb';
Readonly my $ACCEPT_LANG_MAX => 256; # max bytes we accept from the header
Readonly my $UA_MAX => 512; # max bytes we accept from HTTP_USER_AGENT
Readonly my $GEO_UNKNOWN => -1; # geo-module sentinel: not yet probed
Readonly my $GEO_ABSENT => 0; # geo-module sentinel: unavailable
Readonly my $GEO_PRESENT => 1; # geo-module sentinel: loaded OK
# Package-level sentinel for Locale::Object's SQLite database. undef = not yet
# probed; 0 = database absent (Windows installers often omit it); 1 = available.
# Package-level (not per-object) because the database either exists on the
# filesystem or it doesn't — there is no per-request variability.
my $_locale_object_db_ok;
# Package-level sentinel for Data::Validate::IP / NetAddr::IP availability.
# NetAddr::IP::UtilPP fails to build on Windows (mask4to6 bad-argument error),
# which cascades to Data::Validate::IP. undef = not yet probed; 0 = broken;
# 1 = available. On first country() call we try to load the module and, if it
# fails, install pure-Perl aliases for the four functions we use.
my $_have_dvip;
# Short-name overrides used when Locale::Object's database is absent and we
# fall back to Locale::Codes::Country. Locale::Codes carries full ISO official
# names (e.g. "United Kingdom of Great Britain and Northern Ireland") while
# Locale::Object returns the common short form ("United Kingdom"). Only
# entries that differ are listed; everything else comes from Locale::Codes.
my %COUNTRY_SHORT_NAMES = (
bo => 'Bolivia',
cd => 'Democratic Republic of the Congo',
fk => 'Falkland Islands',
fm => 'Micronesia',
gb => 'United Kingdom',
ir => 'Iran',
kp => 'North Korea',
kr => 'South Korea',
md => 'Moldova',
nl => 'Netherlands',
ps => 'Palestine',
tw => 'Taiwan',
tz => 'Tanzania',
us => 'United States',
ve => 'Venezuela',
);
Readonly my %RTL_LANGS => (map { $_ => 1 } # ISO 639-1 codes whose primary script is RTL
qw(ar dv fa he ku ps sd ug ur yi));
=head1 NAME
CGI::Lingua - Create a multilingual web page
=head1 VERSION
Version 0.85
=cut
=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>';
lib/CGI/Lingua.pm view on Meta::CPAN
for my $entry (@{$sorted}) {
my ($tag) = @{$entry};
next if $tag =~ /^..-../; # already tried in the pair scan
$self->_debug(__PACKAGE__, ': ', __LINE__, ": see if $tag is supported");
if($i18n->accepts($tag, $self->{_supported})) {
$self->_debug("Fallback to $tag as best alternative");
return $tag;
}
}
return;
}
# ── _resolve_match ────────────────────────────────────────────────────────
# Purpose: Given a matched code $l (possibly xx or xx-yy), populate all
# of _slanguage, _rlanguage, _sublanguage and their code fields.
# Entry: $l — 2-char or xx-yy language code; $requested_sublanguage —
# 2-char variety code or undef; $http_accept_language — full header.
# Exit: Returns true (1) if the caller should return immediately.
# Side Effects: Mutates $self->{_slanguage}, _rlanguage, _sublanguage, etc.
sub _resolve_match
{
my ($self, $l, $requested_sublanguage, $http_accept_language) = @_;
$self->_debug("l: $l");
if($l !~ /^..-../) {
# Base-language match (e.g. 'en') — no sublanguage component
return $self->_resolve_base_match($l, $requested_sublanguage, $http_accept_language);
} elsif($l =~ /(.+)-(..)$/) {
# Sublanguage match (e.g. 'en-gb') — resolve both language and variant
return $self->_resolve_sublanguage_match($l, $1, $2, $http_accept_language);
}
return 0;
}
# ── _resolve_base_match ───────────────────────────────────────────────────
# Purpose: Handle the case where a base-language code matched (no hyphen).
# Sets _slanguage, _rlanguage; appends sublanguage name to rlanguage
# when the client requested one we don't support.
# Entry: $l — 2-char code; $requested_sublanguage — optional; $header.
# Exit: 1 to signal caller should return, 0 otherwise.
# Side Effects: Mutates slanguage, rlanguage, slanguage_code_alpha2.
sub _resolve_base_match
{
my ($self, $l, $requested_sublanguage, $header) = @_;
$self->{_slanguage} = $self->_code2language($l);
return 0 unless $self->{_slanguage};
$self->_debug("_slanguage: $self->{_slanguage}");
$self->{_slanguage_code_alpha2} = $l;
$self->{_rlanguage} = $self->{_slanguage};
# Attempt to name the sublanguage the client actually asked for
my $sl;
if($header =~ /..-(..)$/) {
$self->_debug($1);
$sl = $self->_code2country($1);
$requested_sublanguage //= $1;
} elsif($header =~ /..-([a-z]{2,3})$/i) {
if($_locale_object_db_ok // 1) {
eval { $sl = Locale::Object::Country->new(code_alpha3 => $1) };
if($@) {
$_locale_object_db_ok = 0 if $@ =~ /database was not in/;
$self->_info($@);
} else {
$_locale_object_db_ok = 1;
}
}
}
if($sl) {
$self->{_rlanguage} .= ' (' . $sl->name() . ')';
} elsif($requested_sublanguage) {
if(my $c = $self->_code2countryname($requested_sublanguage)) {
$self->{_rlanguage} .= " ($c)";
} else {
$self->{_rlanguage} .= " (Unknown: $requested_sublanguage)";
}
}
return 1;
}
# ── _resolve_sublanguage_match ────────────────────────────────────────────
# Purpose: Handle the case where the full xx-yy code matched in the
# supported list. Resolves the variety name and caches results.
# Entry: $l — full code e.g. 'en-gb'; $alpha2 — 'en'; $variety — 'gb';
# $header — full Accept-Language value.
# Exit: 1 to signal caller should return, 0 otherwise.
# Side Effects: Mutates _slanguage, _rlanguage, _sublanguage and code fields;
# writes to cache.
sub _resolve_sublanguage_match
{
my ($self, $l, $alpha2, $variety, $header) = @_;
my $i18n = I18N::AcceptLanguage->new(strict => 1);
my $accepts = $i18n->accepts($l, $self->{_supported});
$self->_debug("accepts = $accepts");
if($accepts) {
$self->_debug("accepts: $accepts");
if($accepts =~ /\-/) {
delete $self->{_slanguage};
} else {
# Cache look-up for the base-language name
my $from_cache;
if($self->{_cache}) {
$from_cache = $self->{_cache}->get($CACHE_NS . "accepts:$accepts");
}
my $slanguage;
if($from_cache) {
$self->_debug("$accepts is in cache as $from_cache");
$slanguage = (split(/=/, $from_cache))[0];
} else {
$slanguage = $self->_code2language($accepts);
}
if($slanguage) {
$self->{_slanguage} = $slanguage;
# Normalise deprecated en-uk variety
if($variety eq 'uk') {
$self->_warn({ warning => "Resetting country code to GB for $header" });
$variety = 'gb';
}
if(defined(my $c = $self->_code2countryname($variety))) {
$self->_debug(__PACKAGE__, ': ', __LINE__, ": setting sublanguage to $c");
$self->{_sublanguage} = $c;
}
$self->{_slanguage_code_alpha2} = $accepts;
$self->{_sublanguage_code_alpha2} = $variety;
if($self->{_sublanguage}) {
$self->{_rlanguage} = "$self->{_slanguage} ($self->{_sublanguage})";
$self->_debug(__PACKAGE__, ': ', __LINE__, ": _rlanguage: $self->{_rlanguage}");
}
unless($from_cache) {
$self->_debug("Set $variety to $slanguage=$accepts");
$self->{_cache}->set(
$CACHE_NS . "accepts:$variety",
"$slanguage=$accepts",
$CACHE_TTL_LONG
) if $self->{_cache};
}
return 1;
}
}
}
# Accepts returned something but we couldn't resolve a language name —
# try harder using the variety code directly
$self->{_rlanguage} = $self->_code2language($alpha2);
$self->_debug("_rlanguage: $self->{_rlanguage}");
return 0 unless $accepts;
$self->_debug("http_accept_language = $header");
$l =~ /(..)-(..)/;
$variety = lc($2);
# Skip numeric/region codes like en-029
if(($variety =~ /[a-z]{2,3}/) && !defined($self->{_sublanguage})) {
$self->_get_closest($alpha2, $alpha2);
$self->_debug("Find the country code for $variety");
if($variety eq 'uk') {
$self->_warn({ warning => "Resetting country code to GB for $header" });
$variety = 'gb';
}
my ($from_cache, $language_name);
if($self->{_cache}) {
$from_cache = $self->{_cache}->get($CACHE_NS . "variety:$variety");
}
if(defined($from_cache)) {
$self->_debug("$variety is in cache as $from_cache");
# Cache stores "countryname=langcode" (e.g. "United Kingdom=en").
# Splitting on = gives the country name as the first field.
($language_name) = split(/=/, $from_cache);
} elsif($_locale_object_db_ok // 1) {
# Locale::Object's SQLite database is absent on some Windows
# installations; the sentinel avoids repeated failed new() calls.
eval {
my $db = Locale::Object::DB->new();
my @results = @{$db->lookup(
table => 'country',
result_column => 'name',
search_column => 'code_alpha2',
value => $variety
)};
$_locale_object_db_ok = 1;
if(defined($results[0])) {
$language_name = $self->_code2countryname($variety);
} else {
$self->_debug("Can't find the country code for $variety in Locale::Object::DB");
}
};
if($@) {
$_locale_object_db_ok = 0
if $@ =~ /database was not in/;
# fall through: $language_name stays undef, caught below
}
}
if($@ || !defined($language_name)) {
$self->_warn({ warning => $@ }) if $@;
# Locale::Object DB may be absent (common on Windows CI); fall back to
# the short-name table / Locale::Codes before giving up.
$language_name = $self->_country_short_name($variety);
}
if(!defined($language_name)) {
$self->_debug(__PACKAGE__, ': ', __LINE__, ': setting sublanguage to Unknown');
$self->{_sublanguage} = 'Unknown';
$self->_warn({ warning => "Can't determine values for $header" });
} else {
$self->{_sublanguage} = $language_name;
$self->_debug('variety name ', $self->{_sublanguage});
if($self->{_cache} && !defined($from_cache)) {
# Store "countryname=langcode" so future cache hits return the country
# name in the first field. Previously this stored the language name
# ("English=en" for en-gb) which was wrong — the cache-hit branch
# split on = and used the first field as the sublanguage (country) name.
$self->_debug("Set variety:$variety to $language_name=$self->{_slanguage_code_alpha2}");
$self->{_cache}->set(
$CACHE_NS . "variety:$variety",
"$language_name=$self->{_slanguage_code_alpha2}",
$CACHE_TTL_LONG
);
}
}
}
if(defined($self->{_sublanguage})) {
$self->{_rlanguage} = "$self->{_slanguage} ($self->{_sublanguage})";
$self->{_sublanguage_code_alpha2} = $variety;
return 1;
}
return 0;
}
# ── _find_language_from_ip ────────────────────────────────────────────────
# Purpose: Fall back to the visitor's IP country when the Accept-Language
# header produced no usable match. Looks up the official language
# of the country and checks it against the supported list.
# Entry: $http_accept_language — may be undef if no header was present.
# Exit: Mutates _slanguage, _rlanguage via _get_closest if a match found.
# Side Effects: Calls country(); may write to cache.
sub _find_language_from_ip
{
my ($self, $http_accept_language) = @_;
my $country = $self->country();
# If country() returned nothing, try to derive from the LANG env var
if(!defined($country) && (my $c = $self->_what_language())) {
if($c =~ /^(..)_(..)/) {
$country = $2;
} elsif($c =~ /^(..)$/) {
$country = $1;
lib/CGI/Lingua.pm view on Meta::CPAN
}
# ── _get_closest ─────────────────────────────────────────────────────────
# Purpose: If $language_string matches the base language of any supported
# entry, set _slanguage and _slanguage_code_alpha2.
# Entry: $language_string — base code e.g. 'en'; $alpha2 — same or variant.
# Exit: Mutates _slanguage and _slanguage_code_alpha2 on match.
sub _get_closest
{
my ($self, $language_string, $alpha2) = @_;
# Map each supported entry to its base language code
my %base_languages =
map { /^(.+)-/ ? ($1 => $_) : ($_ => $_) } @{$self->{_supported}};
if(exists $base_languages{$language_string}) {
$self->{_slanguage} = $self->{_rlanguage};
$self->{_slanguage_code_alpha2} = $alpha2;
}
}
# ── _what_language ────────────────────────────────────────────────────────
# Purpose: Return the raw (validated, untainted) Accept-Language string,
# consulting in priority order: cached value, CGI lang= param,
# HTTP_ACCEPT_LANGUAGE env var, LANG env var (local/debug mode).
# Entry: May be called as a class method (no $self->{...} access) or
# as an object method.
# Exit: A validated language string, or undef if nothing available.
# Side Effects: Caches result in $self->{_what_language} on object calls.
sub _what_language {
my $self = $_[0];
if(ref($self)) {
$self->_trace('Entered _what_language');
if(defined($self->{_what_language})) {
$self->_trace('_what_language: returning cached value: ', $self->{_what_language});
return $self->{_what_language};
}
if(my $info = $self->{_info}) {
if(my $rc = $info->lang()) {
$self->_trace("_what_language set language to $rc from the lang argument");
return $self->{_what_language} = $rc;
}
}
}
if(my $raw_lang = $ENV{'HTTP_ACCEPT_LANGUAGE'}) {
# Validate and untaint — RFC 7231 §5.3.5 character set plus * wildcard
if($raw_lang =~ /^([A-Za-z0-9\-,;=.*\s]{1,$ACCEPT_LANG_MAX})$/a) {
my $rc = $1; # untainted
if(ref($self)) {
return $self->{_what_language} = $rc;
}
return $rc;
} elsif(ref($self)) {
$self->_warn({ warning => 'HTTP_ACCEPT_LANGUAGE contains invalid characters; ignoring' });
}
}
if(defined($ENV{'LANG'})) {
# Running locally (debug mode) — derive from system locale.
# Apply the same untainting discipline as HTTP_ACCEPT_LANGUAGE: only
# alphanumeric, hyphen, underscore, and dot are legitimate in a POSIX
# locale name (e.g. "en_US.UTF-8", "de_DE", "ja"). Anything else is
# either malformed or an injection attempt; discard it silently.
if($ENV{'LANG'} =~ /^([A-Za-z0-9_.\-]{1,$ACCEPT_LANG_MAX})$/a) {
my $rc = $1; # untainted
if(ref($self)) {
return $self->{_what_language} = $rc;
}
return $rc;
} elsif(ref($self)) {
$self->_warn({ warning => 'LANG contains invalid characters; ignoring' });
}
}
return;
}
=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 EXAMPLE
# With mod_geoip (fastest - no IP lookup at all):
local $ENV{GEOIP_COUNTRY_CODE} = 'DE';
print $l->country(); # "de"
# With REMOTE_ADDR and IP::Country installed:
local $ENV{REMOTE_ADDR} = '8.8.8.8';
print $l->country(); # "us" (depends on geo database)
=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"
=head3 PSEUDOCODE
1. Return cached _country if set
2. Check GEOIP_COUNTRY_CODE env var (mod_geoip); validate /^[A-Z]{2}$/
3. Check HTTP_CF_IPCOUNTRY (Cloudflare); skip 'XX'; validate /^[A-Z]{2}$/
4. Untaint and validate REMOTE_ADDR; return undef if absent or invalid
5. Skip private and loopback IPs (return undef)
6. Check CHI cache; return cached value if present
7. Try IP::Country::Fast (local DB, fastest)
8. Try Geo::IP (local DB)
9. Try Geo::IPfree (local DB, skip $BROKEN_GEOIPFREE)
lib/CGI/Lingua.pm view on Meta::CPAN
{
my ($self, $ip) = @_;
# Prefer Net::Subnet for correctness; fall back to the pure-Perl helper
# when it is absent (Socket6, its indirect dep, fails to build on Windows).
my $in_baidu;
if(eval { require Net::Subnet; Net::Subnet->import(); 1 }) {
$in_baidu = subnet_matcher($BAIDU_SUBNET)->($ip);
} else {
$in_baidu = _in_baidu_subnet($ip);
}
if($in_baidu) {
$self->{_country} = 'cn';
} else {
$self->_info("$ip has country of eu");
$self->{_country} = 'Unknown';
}
}
# ── _load_geoip ───────────────────────────────────────────────────────────
# Purpose: Probe for the Geo::IP database file and the Geo::IP module;
# set _have_geoip and initialise _geoip on success.
# Entry: _have_geoip must be GEO_UNKNOWN.
# Exit: _have_geoip set to GEO_PRESENT or GEO_ABSENT.
# Side Effects: Requires Geo::IP; opens GeoIP.dat.
sub _load_geoip
{
my $self = shift;
# Check for the database file before even trying to load the module
# (avoids noisy errors on Windows — CPANTESTERS report 54117bd0)
my $db_present = (
(($^O eq 'MSWin32') && (-r 'c:/GeoIP/GeoIP.dat'))
|| (-r '/usr/local/share/GeoIP/GeoIP.dat')
|| (-r '/usr/share/GeoIP/GeoIP.dat')
);
unless($db_present) {
$self->{_have_geoip} = $GEO_ABSENT;
return;
}
eval { require Geo::IP };
if($@) {
$self->{_have_geoip} = $GEO_ABSENT;
return;
}
# No ->import(): Geo::IP->open() and Geo::IP->new() are class methods; import unneeded.
$self->{_have_geoip} = $GEO_PRESENT;
# GEOIP_STANDARD = 0 (can't use the constant name directly)
if(-r '/usr/share/GeoIP/GeoIP.dat') {
$self->{_geoip} = Geo::IP->open('/usr/share/GeoIP/GeoIP.dat', 0);
} else {
$self->{_geoip} = Geo::IP->new(0);
}
}
=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 EXAMPLE
local $ENV{REMOTE_ADDR} = '8.8.8.8';
my $locale = $l->locale();
if (defined $locale) {
print $locale->name(); # e.g. "United States"
print $locale->currency_code(); # e.g. "USD"
}
=head3 API SPECIFICATION
Input: none beyond $self
Returns: Locale::Object::Country | undef
=head3 PSEUDOCODE
1. Return cached _locale immediately if already computed
2. Parse HTTP_USER_AGENT parenthetical for xx-YY language tag
3. Try HTTP::BrowserDetect on the full User-Agent string
4. Fall back to country() IP lookup
5. Fall back to GEOIP_COUNTRY_CODE env var (ISO 3166-1 validated)
6. Return undef if all strategies fail
=cut
sub locale {
my $self = shift;
return $self->{_locale} if $self->{_locale};
# Validate and untaint HTTP_USER_AGENT before passing to any parser.
# The User-Agent header is attacker-controlled; apply the same discipline
# as HTTP_ACCEPT_LANGUAGE. Printable ASCII (0x20-0x7e), bounded length.
my $agent;
if(defined(my $raw_agent = $ENV{'HTTP_USER_AGENT'})) {
if($raw_agent =~ /^([\x20-\x7e]{1,$UA_MAX})$/a) {
$agent = $1; # untainted
} else {
$self->_warn({ warning => 'HTTP_USER_AGENT contains invalid characters or exceeds length limit; ignoring' });
}
}
# First try: parse the language tag from the User-Agent parenthetical
if(defined($agent) && ($agent =~ /\((.+)\)/)) {
foreach(split(/;/, $1)) {
my $candidate = $_;
$candidate =~ s/^\s+|\s+$//g; # trim both ends
if($candidate =~ /^[a-zA-Z]{2}-([a-zA-Z]{2})$/) {
local $SIG{__WARN__} = undef;
if(my $c = $self->_code2country($1)) {
$self->{_locale} = $c;
return $c;
}
}
}
# Second try: HTTP::BrowserDetect (works for more User-Agents)
if(eval { require HTTP::BrowserDetect }) {
HTTP::BrowserDetect->import();
my $browser = HTTP::BrowserDetect->new($agent);
# Validate country() result before use — the return value comes from
# the third-party module and is not yet untainted or range-checked.
if($browser) {
my $bc = $browser->country() // '';
if($bc =~ /^([A-Za-z]{2})$/a) {
if(my $c = $self->_code2country($1)) {
$self->{_locale} = $c;
return $c;
}
}
}
}
}
# Third try: IP address
my $country = $self->country();
if($country) {
$country =~ s/[\r\n]//g;
my $c;
eval {
local $SIG{__WARN__} = sub { die $_[0] };
$c = $self->_code2country($country);
};
unless($@) {
if($c) {
$self->{_locale} = $c;
return $c;
}
}
}
# Fourth try: mod_geoip env var — apply the same ISO 3166-1 validation
# used in country() to guard against spoofed or malformed values
if(defined($ENV{'GEOIP_COUNTRY_CODE'})) {
if($ENV{'GEOIP_COUNTRY_CODE'} =~ /^([A-Z]{2})$/a) {
if(my $c = $self->_code2country(lc($1))) {
$self->{_locale} = $c;
return $c;
}
}
}
return;
}
=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 EXAMPLE
local $ENV{REMOTE_ADDR} = '8.8.8.8';
my $tz = $l->time_zone();
print $tz // 'unknown'; # e.g. "America/New_York"
=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.
=head3 PSEUDOCODE
1. Return cached _timezone immediately if already computed
2. If REMOTE_ADDR is set:
a. Untaint and validate the IP
b. Try Geo::IP->time_zone() (local DB)
c. Try LWP::Simple::WithCache + JSON::Parse against ip-api.com
d. Fall back to LWP::Simple + JSON::Parse against ip-api.com
e. Warn and return undef if neither LWP variant is installed
3. If REMOTE_ADDR is absent (local/CLI mode):
a. Read /etc/timezone if readable
b. Fall back to DateTime::TimeZone::Local->TimeZone()->name()
4. Warn "Couldn't determine the timezone" and return undef if all fail
=cut
sub time_zone {
my $self = shift;
$self->_trace('Entered time_zone');
if($self->{_timezone}) {
$self->_trace('quick return: ', $self->{_timezone});
return $self->{_timezone};
}
my $raw_ip = $ENV{'REMOTE_ADDR'};
if(defined $raw_ip) {
lib/CGI/Lingua.pm view on Meta::CPAN
my $path = "$dir/$code.$ext";
return $path if -e $path;
}
return;
}
# ── _code2language ────────────────────────────────────────────────────────
# Purpose: Translate a 2-char language code to its English name, with
# optional CHI caching.
# Entry: $code — 2-char ISO 639-1 code; must be defined and non-empty.
# Exit: Human-readable language name string, or undef.
# Side Effects: Reads/writes cache.
sub _code2language
{
my ($self, $code) = @_;
return unless $code;
if(defined($self->{_country})) {
$self->_debug("_code2language $code, country ", $self->{_country});
} else {
$self->_debug("_code2language $code");
}
unless($self->{_cache}) {
return Locale::Language::code2language($code);
}
if(my $from_cache = $self->{_cache}->get($CACHE_NS . "code2language:$code")) {
$self->_trace("_code2language found in cache $from_cache");
return $from_cache;
}
# Compute, cache, then return the value separately —
# CHI->set() is not guaranteed to return the stored value across all drivers
$self->_trace('_code2language not in cache, storing');
my $name = Locale::Language::code2language($code);
if(defined $name) {
$self->{_cache}->set($CACHE_NS . "code2language:$code", $name, $CACHE_TTL_LONG);
}
return $name;
}
# ── _code2country ─────────────────────────────────────────────────────────
# Purpose: Translate a 2-char country code to a Locale::Object::Country
# object, suppressing the expected "No result found" warning.
# Entry: $code — 2-char ISO 3166-1 alpha-2 code (any case).
# Exit: Locale::Object::Country object, or undef.
# Side Effects: None beyond the Locale::Object::Country look-up.
sub _code2country
{
my ($self, $code) = @_;
return unless $code;
if($self->{_country}) {
$self->_trace(">_code2country $code, country ", $self->{_country});
} else {
$self->_trace(">_code2country $code");
}
my $rc;
if($_locale_object_db_ok // 1) {
# Suppress the routine "No result found" warning; catch the database-
# absent exception that Windows installations sometimes throw.
local $SIG{__WARN__} = sub {
warn $_[0] unless $_[0] =~ /No result found in country table/;
};
eval { $rc = Locale::Object::Country->new(code_alpha2 => $code) };
if($@) {
$_locale_object_db_ok = 0
if $@ =~ /database was not in/;
$rc = undef;
} else {
$_locale_object_db_ok = 1;
}
}
$self->_trace('<_code2country ', $code || 'undef');
return $rc;
}
# ── _country_short_name ───────────────────────────────────────────────────
# Purpose: Return the common short English name for an ISO 3166-1 alpha-2
# code when Locale::Object's database is unavailable. Uses
# %COUNTRY_SHORT_NAMES overrides for codes where Locale::Codes
# returns the full ISO official name rather than the short form.
# Entry: $code — 2-char country code (any case).
# Exit: Short name string, or undef.
sub _country_short_name
{
my ($self, $code) = @_;
return unless defined($code);
my $lc = lc($code);
return $COUNTRY_SHORT_NAMES{$lc} if exists $COUNTRY_SHORT_NAMES{$lc};
# Locale::Object may have partially initialised Locale::Codes::Country as a
# dependency before we get here; suppress the spurious 'redefine' warning
# that some Perl/Locale::Codes combinations produce on first full load.
{ local $SIG{__WARN__} = sub { warn $_[0] unless $_[0] =~ /redefined/ };
require Locale::Codes::Country; }
return Locale::Codes::Country::code2country($lc, 'alpha-2');
}
# ── _code2countryname ─────────────────────────────────────────────────────
# Purpose: Translate a 2-char country code to its English name string,
# with optional CHI caching.
# Entry: $code — 2-char ISO 3166-1 alpha-2 code.
# Exit: Country name string, or undef.
# Side Effects: Reads/writes cache.
sub _code2countryname
{
my ($self, $code) = @_;
return unless $code;
$self->_trace(">_code2countryname $code");
unless($self->{_cache}) {
my $country = $self->_code2country($code);
return $country->name if defined($country);
return $self->_country_short_name($code);
}
if(my $from_cache = $self->{_cache}->get($CACHE_NS . "code2countryname:$code")) {
$self->_trace("_code2countryname found in cache $from_cache");
return $from_cache;
}
my $name;
if(my $country = $self->_code2country($code)) {
$name = $country->name();
} else {
# Locale::Object database absent (common on Windows); fall back to
# Locale::Codes::Country with a short-name correction table.
$name = $self->_country_short_name($code);
}
lib/CGI/Lingua.pm view on Meta::CPAN
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 sublanguage
sublanguage : CGI::Lingua -> Str | undef
result = country_name(sublanguage_code_alpha2(self))
when sublanguage_code_alpha2(self) is defined,
undef otherwise
=head2 language_code_alpha2
language_code_alpha2 : CGI::Lingua -> Str(2) | undef
result = base_code(matched_supported_entry)
when a supported language was matched, undef otherwise
=head2 sublanguage_code_alpha2
sublanguage_code_alpha2 : CGI::Lingua -> Str(2) | undef
result = variety_code(matched_supported_entry) | undef
=head2 requested_language
requested_language : CGI::Lingua -> Str
result = name(base) + " (" + name(variety) + ")"
when variety is known,
= name(base) when no variety,
= 'Unknown' when no language detected
=head2 country
country : CGI::Lingua -> Str(2,lowercase) | undef
-- 'Unknown' returned only in the EU/Baidu special case
result = lc(code) where code satisfies ISO 3166-1 alpha-2
| undef when IP is private, loopback, or unresolvable
=head2 locale
locale : CGI::Lingua -> Locale::Object::Country | undef
-- Best-guess detection; not guaranteed accurate.
result = first defined value from:
1. UA parenthetical language tag
2. HTTP::BrowserDetect country
3. country() IP lookup
4. GEOIP_COUNTRY_CODE env var
=head2 time_zone
time_zone : CGI::Lingua -> Str | undef
result is an IANA timezone name (e.g. 'Europe/London') or undef
=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 x N -> PluralCategory
plural_category(s, n) = PLURAL_RULES[language_code_alpha2(s)](trunc(n))
-- Falls back to English rule (n=1 -> 'one'; else 'other')
-- when language_code_alpha2(s) is undef or not in the rules table.
=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.
Usage is subject to the GPL2 licence terms.
If you use it,
please let me know.
=cut
1; # End of CGI::Lingua
( run in 1.424 second using v1.01-cache-2.11-cpan-ff9377addf4 )