CGI-Lingua
view release on metacpan or search on metacpan
validation) as aliases for is_ipv4(), is_ipv6(), is_private_ip(), and
is_loopback_ip() so the rest of country() is unchanged on both platforms
- _code2countryname(): when Locale::Object's database is absent, fall back to
Locale::Codes::Country::code2country() via the new _country_short_name()
helper; a %COUNTRY_SHORT_NAMES table overrides the ~15 codes where
Locale::Codes returns the full ISO official name (e.g. "United Kingdom of
Great Britain and Northern Ireland") instead of the common short form
("United Kingdom") — fixes sublanguage() returning 'Unknown' for en-gb and
en-us on Windows CI where Locale::Object's SQLite database is not installed
- Locale::Object::Country->new() and Locale::Object::DB->new() now wrapped in
eval at every call site; a package-level $_locale_object_db_ok sentinel
(undef=unchecked, 0=absent, 1=present) prevents repeated failed attempts on
systems where Locale::Object's SQLite database is missing — common on Windows
CI runners where the .db file is not installed alongside the module; the
module now degrades gracefully (sublanguage/country name returns 'Unknown'
rather than dying) instead of propagating the "database was not in" exception
- Make Net::Subnet an optional (recommended) dependency rather than required;
Net::Subnet depends on Socket6 which requires C compilation and fails to
build on Windows; add a pure-Perl fallback (_in_baidu_subnet) for the single
185.10.104.0/22 check in _handle_eu_country so the module continues to
detect Baidu crawler IPs even when Net::Subnet is absent
_have_ipcountry was omitted, so on machines with IP::Country installed the
lookup ran against 8.8.8.8 and returned a real country code
0.83 Tue Jul 28 20:30:23 EDT 2026
[ Security ]
- Replace Storable::nfreeze/thaw with JSON::PP encode/decode for cache
serialisation in new() and DESTROY(); Storable::thaw can execute arbitrary
Perl code via STORABLE_thaw hooks if an attacker writes a crafted blob to
the cache backend (world-writable /tmp, unauthenticated Redis/Memcached),
whereas JSON cannot execute code regardless of content
- locale(): validate and untaint HTTP_USER_AGENT before parsing — apply the
same printable-ASCII + length-cap discipline as HTTP_ACCEPT_LANGUAGE; also
validate the country code returned by HTTP::BrowserDetect against
/^([A-Za-z]{2})$/ before passing to _code2country()
- translation_file(): reject $dir containing '..' or null bytes to prevent
path-traversal attacks when callers pass user-controlled input as $dir
- _clean_country_code(): replace strip-then-return with a single anchored
capture /^([A-Za-z]{2})\s*(?:#.*)?$/ that returns undef for any malformed
value; callers in _resolve_country_via_whois() fall through to IANA on
undef rather than propagating a malformed code string
- geoplugin.net URL changed from http:// to https:// to prevent MITM
- Makefile.PL: convert string eval ('require Module') to block eval
({ require Module; 1 }) for module-probe checks; string eval produces
deprecation warnings on modern Perls and bypasses taint propagation
- LIMITATIONS: add note that country() does not cache undef results for
private/loopback IPs; document the intentional reason (lazy REMOTE_ADDR
read design); remove dangling inline FIXME reference
- _warn(): call Params::Get::get_params once (was called twice, once per branch)
- Bump $VERSION to 0.83 and update POD Version line accordingly
- Add =head3 EXAMPLE, inline =head3 FORMAL SPECIFICATION, and =head3 PSEUDOCODE to
all public methods that were missing them: language, sublanguage, language_code_alpha2,
sublanguage_code_alpha2, requested_language, country, locale, time_zone, is_rtl,
text_direction, plural_category, translation_file
- Add t/cgi_security.t: 34 penetration subtests covering env-var injection
(CRLF, null-byte, shell meta, overlength), country-code format enforcement,
Whois/JSON API response injection, cache-key poisoning, IPv4-mapped IPv6
normalisation, and translation_file() extension path-traversal; two confirmed
findings documented as TODO (JSON countryCode and time_zone() format not
validated after external fetch)
0.82 Sat Jul 11 20:41:15 UTC 2026
[ Distribution ]
unnecessary (fully-qualified function names are used throughout) and on some
older versions of LWP::Simple::WithCache the import() reinstalls the real get
in the symbol table, overwriting any mock/spy and causing real network calls
during testing (fixes CPAN Testers failures for spy subtests in t/integration.t)
[ Enhancement ]
- Add explicit use Carp qw(croak carp); remove Carp from Class::Autouse so
croak/carp are resolved at compile time rather than lazy-loaded at runtime
- Expand use autodie from qw(:file) to qw(:all) for fuller fatal-error coverage
- plural_category(): croak on undef $n rather than silently treating it as 0
- Change return undef to bare return in _scan_plain_tokens, locale(), and
_code2countryname (perlcritic ProhibitExplicitReturnUndef)
- _what_language(): use defined() check for cached value to guard against a
falsy language tag silently bypassing the cache
- Add is_rtl(): returns 1 when the negotiated language uses a right-to-left
script (Arabic, Hebrew, Persian, Urdu, Yiddish, Dhivehi, Pashto, Sindhi,
Uyghur, Kurdish)
- Add text_direction(): returns 'rtl' or 'ltr' for direct use as HTML dir attr
- Add plural_category($n): returns CLDR plural category (zero/one/two/few/many/other)
for the negotiated language using embedded rules for ~70 languages
- Add translation_file($dir, $ext?): returns path to best matching translation
- Added sanity testing for the supported argument
- Decompose _find_language() into focused helper methods for readability and testability
- Add Readonly constants for all magic strings and sentinel values
- Add use autodie :file
- Add =head1 LIMITATIONS POD section
- Add API SPECIFICATION, MESSAGES, FORMAL SPECIFICATION sections to public method POD
- Add Purpose/Entry/Exit/Side-Effects comment headers to all private methods
[ Tests ]
- Replace Test::MockModule with Test::Mockingbird in t/30-basics.t
- Add t/locales.t: geographic (GB/US/FR/DE/CN) and POSIX locale independence tests
- Add t/function.t: white-box subtests for every public and private method (92 subtests)
- Add t/unit.t: black-box subtests driven strictly by POD API contracts (62 subtests)
- Add t/integration.t: end-to-end tests covering multi-method coherence, priority negotiation, cache DESTROY→thaw, concurrent object isolation, clone behaviour, spy-verified network routing, and optional-dependency fallback (27 subtests)
- Add t/edge_cases.t: hostile, pathological, boundary, and security subtests; exposed the cache-removal key bug and the uncaught JSON parse die (48 subtests)
- Add t/extended_tests.t: coverage-gap subtests targeting uncovered branches in _resolve_country_via_whois, _find_language_from_ip, _resolve_sublanguage_match, time_zone, locale, _log, and DESTROY (54 subtests)
- Fix t/function.t: _log test now injects spy logger directly to bypass Object::Configure
- Fix t/function.t: _warn test clears Object::Configure logger to exercise Carp path
- Fix t/function.t: locale() subtest now calls locale() and asserts return value
- Update t/function.t: document that plain hashref logger is converted by Object::Configure
- Fix t/30-basics.t: pre-require LWP::Simple::WithCache before mocking to prevent lazy-load
overwriting the mock; wrap restore_all() in local $SIG{__WARN__} to suppress prototype
mismatch warnings; changed v4-mapped IPv6 test IP from TEST-NET-1 to 8.8.8.8
- Fix t/integration.t: don't_use_ip subtest now explicitly sets _have_geoip and
_have_geoipfree to 0 after construction so the test passes on machines where those
modules are installed; extended to 29 subtests; added _inject_geoip and
_inject_geoipfree helpers and subtests for Geo::IP and Geo::IPfree fallback paths
- Fix t/locales.t: add delete $ENV{LANG} inside each GeoIP subtest local %ENV block;
fix concurrent-instances subtest to call country() inside the correct REMOTE_ADDR scope;
add LANG env-var fallback subtest; add croak message locale-independence subtest
[ Security ]
- Validate and untaint HTTP_ACCEPT_LANGUAGE before use (taint-mode compliance)
- Validate GEOIP_COUNTRY_CODE and HTTP_CF_IPCOUNTRY against ISO 3166-1 alpha-2 format before use
- Validate and untaint REMOTE_ADDR via regex capture before passing to geo-lookup modules
- Replace string eval with block eval for dynamic loading of Geo::IP and Geo::IPfree
- Apply ISO 3166-1 alpha-2 validation to GEOIP_COUNTRY_CODE in locale() to match country()
- Validate and untaint REMOTE_ADDR in time_zone() before URL construction
- _what_language(): $ENV{LANG} was consumed without untainting, violating the security
invariant applied to all other env-vars; added [A-Za-z0-9_.\-]{1,N} regex capture
[ Documentation ]
- country() POD: return spec incorrectly listed 'Unknown' as a normal return value
- Corrected es-419 BUGS description ("3 characters" -> "3-digit UN M.49 sub-tag")
- Fixed two misspellings of I18N::AcceptLanguage in SEE ALSO and BUGS sections
- Added LIMITATIONS entry documenting IPv4-mapped IPv6 normalisation behaviour
- Updated time_zone MESSAGES POD to reflect removal of the Carp::croak
Allow arguments to new() to be hash or hashref
0.48 Wed Jan 30 14:12:01 EST 2013
Fixed t/eu.t which gave false negatives on systems with Geo::IP
installed
Added CloudFlare optimisation to country()
0.47 Sat Jan 19 09:21:56 EST 2013
Handle en-029
Remove t/unused.t - now use t/vars.t
Handle unknown country EU in locale(). Beefed up t/eu.t
0.46 Sun Dec 30 11:07:15 EST 2012
Handle uninitialised variable in country()
Added t/strict.t
0.45 Thu Dec 6 08:33:12 EST 2012
Fixed t/eu.t on systems with Geo::IP
0.44 Mon Dec 3 08:47:12 EST 2012
Fixed t/unused.t for Windows - removed unneeded dependency
0.39 Fri Jul 13 09:44:11 BST 2012
Use mod_geoip as a fall back if it is installed
Fixed unitialized variable in test
Better handling of automatic build environments
0.38 Sat Jun 2 15:23:40 EDT 2012
Fix use of unitialised variable
Handle remote address '::1' (IPv6)
Added test for RT77332
locale(): better handling of whois failure
Handle case where Whois entry consists only of a newline
0.37 Tue May 15 14:37:47 EDT 2012
Fix strange sublanguage handling when
'HTTP_ACCEPT_LANGUAGE = 'en-gb,en;q=0.5,x-ns1Gcc7A8xaNx1,x-ns294eMxcVGQb2'
0.36 Sat May 12 09:04:04 EDT 2012
Catch connection timeouts to whois.apnic.net
0.35 Thu May 3 10:17:04 BST 2012
0.28 Thu Oct 6 13:44:20 EDT 2011
Improved handling of connection failure to whois.arin.net
Fix the argument to syslog
Try to avoid the Carp call within Locale::Object::Country
0.27 Mon Sep 19 15:07:58 EDT 2011
Improved handling
Added syslog argument to new
0.26 Fri Sep 9 11:13:02 EDT 2011
Added some tests and clarified the locale() documentation
Added subcountry_code_alpha2()
0.25 Tue Sep 6 13:08:06 EDT 2011
Only call HTTP::BrowserDetect if we're in a CGI environment
0.24 Sun Sep 4 08:53:50 EDT 2011
locale now falls back to HTTP::BrowserDetect if it's present
0.23 Fri Aug 26 13:19:51 EDT 2011
Added t/critic.t
Correct documentation about what class is returned by locale()
0.22 Wed Aug 10 13:46:42 EDT 2011
Fixed unitialised variable in some circumstances when checking language
0.21 Wed Jul 20 13:39:57 EDT 2011
Added locale method
Had another go at returning sensible values if a requested
sublanguage can't be honoured
Added test for RT69509
0.20 Fixed some 'Can't call method "name" on an undefined value' when the
browser suggests more than one language and a requested
sublanguage isn't available
0.19 More sensible choice of real world language requirements, for example
a browser requesting US English on a site that only delivers
t/function.t
t/fuzz.t
t/gv.t
t/hk.t
t/hp-tablet.t
t/integration.t
t/kwalitee.t
t/language.t
t/lib/MyLogger.pm
t/links.t
t/locale.t
t/locales.t
t/logger.t
t/manifest.t
t/metrics.t
t/modules-used.t
t/mutant_killers.t
t/no404s.t
t/noopentickets.t
t/noplan.t
t/pod-cm.t
t/pod-snippets.t
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)
10. Try geoplugin.net JSON API (LWP::Simple::WithCache or LWP::Simple)
11. Last resort: Net::Whois::IP then Net::Whois::IANA
12. Sanitise: discard numeric, normalise HK->CN, handle EU special case
13. Store in CHI cache; return result
## 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 [Locale::Object::Country](https://metacpan.org/pod/Locale%3A%3AObject%3A%3ACountry) object.
### 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"
}
### API SPECIFICATION
Input: none beyond $self
Returns: Locale::Object::Country | undef
### 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
## time\_zone
Returns the timezone of the web client.
= name(base) when no variety,
= 'Unknown' when no language detected
## 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
## 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
## time\_zone
time_zone : CGI::Lingua -> Str | undef
lib/CGI/Lingua.pm view on Meta::CPAN
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
lib/CGI/Lingua.pm view on Meta::CPAN
$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 {
lib/CGI/Lingua.pm view on Meta::CPAN
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);
lib/CGI/Lingua.pm view on Meta::CPAN
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' });
}
lib/CGI/Lingua.pm view on Meta::CPAN
$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' });
lib/CGI/Lingua.pm view on Meta::CPAN
# 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.
lib/CGI/Lingua.pm view on Meta::CPAN
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
lib/CGI/Lingua.pm view on Meta::CPAN
= 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
t/30-basics.t view on Meta::CPAN
Test::Mockingbird::mock('Locale::Object::Country', 'code_alpha2', sub { 'MC' });
# Locale from Locale::Object::Country
subtest 'From User-Agent' => sub {
local %ENV = (
%{$mock_env},
HTTP_USER_AGENT => 'Mozilla/5.0 (X11; Linux x86_64; rv:91.0) en-US'
);
my $lingua = CGI::Lingua->new(supported => ['en']);
my $locale = $lingua->locale();
isa_ok($locale, 'Locale::Object::Country', 'Locale object');
is($locale->code_alpha2(), 'MC', 'Correct country from Locale::Object::Country');
};
# Invalid country code
subtest 'Invalid Code' => sub {
local %ENV = %{$mock_env};
$ENV{GEOIP_COUNTRY_CODE} = 'XX';
# Mock _code2country to return our mock country object
Test::Mockingbird::mock('CGI::Lingua', '_code2country', sub {
my ($self, $code) = @_;
return bless { code => lc $code }, 'Locale::Object::Country';
});
my $lingua = CGI::Lingua->new(supported => ['en']);
Test::Mockingbird::mock('CGI::Lingua', '_code2country', sub { undef });
ok(!defined $lingua->locale(), 'Undefined for invalid country code');
};
{ local $SIG{__WARN__} = sub {}; Test::Mockingbird::restore_all() }
};
subtest 'IPv6 Handling' => sub {
my $ipv6_public = '2001:db8::1'; # Test documentation IP
my $ipv6_private = 'fd00::1'; # ULA private IP
my $ipv6_loopback = '::1';
my $ipv6_v4mapped = '::ffff:8.8.8.8'; # Google DNS — public, not TEST-NET-1
t/40-more.t view on Meta::CPAN
$obj = CGI::Lingua->new(supported => ['en']);
like $obj->country, qr/^[a-z]{2}$/, 'Country returns valid code for public IP';
$obj = CGI::Lingua->new(supported => ['en-gb']);
$ENV{REMOTE_ADDR} = '192.168.1.1';
is $obj->country, undef, 'Country returns undef for private IP';
$ENV{REMOTE_ADDR} = '::1';
is $obj->country, undef, 'Country returns undef for IPv6 loopback';
# Test locale and time_zone methods
$ENV{REMOTE_ADDR} = '8.8.8.8';
$obj = CGI::Lingua->new(supported => ['en']);
isa_ok $obj->locale, 'Locale::Object::Country', 'Locale returns country object';
like $obj->time_zone, qr/.+/, 'Time zone returns string';
# Test DESTROY method
{
my $cache = CHI->new(driver => 'Memory', global => 1);
my $obj = CGI::Lingua->new(supported => ['en'], cache => $cache);
$ENV{REMOTE_ADDR} = '192.168.1.1';
}
pass 'DESTROY called without errors';
t/cgi_security.t view on Meta::CPAN
# Attack categories covered:
# 1. Shell metacharacter / command injection via env vars
# 2. CRLF / header injection via env vars
# 3. Null-byte injection
# 4. Overlength header (DoS / buffer edge)
# 5. Country-code format violations (length, non-alpha, embedded control chars)
# 6. IP address format violations (path traversal, shell meta in REMOTE_ADDR)
# 7. Whois response injection (CRLF, trailing-comment bypass, MITM data)
# 8. JSON API response injection (XSS payload in country/timezone fields)
# 9. Cache key poisoning (namespace prefix collision, split() separator abuse)
# 10. HTTP_USER_AGENT CRLF and XSS injection (locale() path)
# 11. Accept-Language q-value boundary and wildcard edge cases
# 12. IPv4-mapped IPv6 normalisation correctness
# 13. Translation-file extension path-traversal guard
# 14. Country-code output validation (final result must be 2 lowercase alpha)
use strict;
use warnings;
use CHI;
use File::Temp qw(tempdir);
t/cgi_security.t view on Meta::CPAN
subtest 'LANG: shell metacharacters are ignored' => sub {
for my $payload ('en_US; rm -rf /', "en_US\r\nX-Header: evil", "en_US\x00") {
local %ENV = (LANG => $payload, REMOTE_ADDR => '127.0.0.1');
my $l = _obj();
# language() must not expose any fragment of the payload
my $lang = $l->language();
unlike($lang // '', qr/[|;&\x60\$\r\n\x00]/, "LANG payload not reflected: " . _abbrev($payload));
}
};
# ── 10. HTTP_USER_AGENT CRLF injection (locale() path) ───────────────────────
# locale() parses the User-Agent parenthetical for a language tag. A crafted
# UA with CRLF could attempt to split the match and inject data.
subtest 'HTTP_USER_AGENT: CRLF in parenthetical does not leak into locale()' => sub {
# The regex /\((.+)\)/ uses `.` which does NOT match \n in default mode,
# so CRLF terminates the match before the injected header.
local %ENV = (
HTTP_USER_AGENT => "Mozilla/5.0 (en-GB\r\nX-Injected: evil)",
REMOTE_ADDR => '127.0.0.1',
);
my $l = _obj();
my $locale = $l->locale();
# If locale() returned anything, its name() must not contain CRLF sequences
if(defined $locale && blessed $locale) {
my $name = $locale->name() // '';
unlike($name, qr/[\r\n]/, 'CRLF not in locale name from UA');
} else {
pass('locale() returned undef for CRLF UA — safe degradation');
}
};
subtest 'HTTP_USER_AGENT: XSS payload in parenthetical does not match lang-tag regex' => sub {
# The lang-tag check requires /^[a-zA-Z]{2}-([a-zA-Z]{2})$/, so an XSS
# payload like "<script>alert(1)</script>" will never pass.
local %ENV = (
HTTP_USER_AGENT => 'Mozilla/5.0 (<script>alert(1)</script>)',
REMOTE_ADDR => '127.0.0.1',
);
my $l = _obj();
my $locale = $l->locale();
if(defined $locale && blessed $locale) {
unlike($locale->name() // '', qr/<script>/i,
'XSS payload not reflected in locale name');
} else {
pass('locale() returned undef for XSS UA — safe');
}
};
subtest 'HTTP_USER_AGENT: null byte in parenthetical does not match lang-tag' => sub {
local %ENV = (
HTTP_USER_AGENT => "Mozilla/5.0 (en-G\x00B)",
REMOTE_ADDR => '127.0.0.1',
);
my $l = _obj();
my $locale = $l->locale();
# A null byte breaks the 2-letter country code match; locale() must return undef
# or a locale that came from a different detection path (IP or GEOIP_COUNTRY_CODE).
pass('locale() did not crash on null byte in UA');
};
# ── 11. Whois response injection (_clean_country_code) ───────────────────────
# If an attacker controls the upstream Whois server (MITM), they can inject
# arbitrary bytes into the country field of the response. _clean_country_code()
# strips CRLFs and trailing comments; the final result must be safe.
subtest '_clean_country_code: strips carriage returns from whois response' => sub {
# Simulate a whois response with an embedded carriage return.
# Real example: some servers return "GB\r" in the Country field.
t/data-flow.t view on Meta::CPAN
# logger is re-injected by new() from $params (Object::Configure provides one).
# Verify heavy non-serialised objects (_ipcountry, _geoip) are NOT present.
ok(!defined($l->{_ipcountry}), '_ipcountry not in thawed object (not serialised)');
ok(!defined($l->{_geoip}), '_geoip not in thawed object (not serialised)');
diag('Thawed object keys: ' . join(', ', sort keys %{$l}))
if $ENV{TEST_VERBOSE};
};
# â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•
# SECTION 5: $_locale_object_db_ok package sentinel — transition and persistence
# â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•
#
# The sentinel starts at undef, moves to 1 (present) or 0 (absent).
# Once set to 0 it must stay 0 (no repeated failed Locale::Object probes).
# Tested indirectly via _code2country and _resolve_sublanguage_match.
subtest '$_locale_object_db_ok: once set to 0, _code2country skips Locale::Object' => sub {
# Force the sentinel to 0 by injecting it at package level.
# CGI::Lingua exposes no public accessor so we use the symbol table.
{
no strict 'refs';
${'CGI::Lingua::_locale_object_db_ok'} = 0;
}
local %ENV = (HTTP_ACCEPT_LANGUAGE => $LANG{EN_GB});
my $l = _obj([$LANG{EN_GB}]);
# With sentinel = 0, _code2country returns undef; _code2countryname should
# fall back to _country_short_name (via %COUNTRY_SHORT_NAMES).
my $sub = $l->sublanguage();
# Reset sentinel to undef so other tests see a clean slate.
{
no strict 'refs';
${'CGI::Lingua::_locale_object_db_ok'} = undef;
}
# The short-name table covers 'gb' → 'United Kingdom'.
is($sub, 'United Kingdom',
'_country_short_name fallback works when sentinel is 0 (no Locale::Object call)');
};
# â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•
# SECTION 6: $_have_dvip sentinel — symbol-table alias installation
# â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•
t/data-flow.t view on Meta::CPAN
$l->country(); # second call: must use cached sentinel
is($l->{_have_ipcountry}, $sentinel_after_first,
'_have_ipcountry unchanged on second call (no re-probe)');
};
# â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•
# SECTION 8: $_ global non-pollution
# â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•
#
# locale() uses an implicit $_ in its foreach loop. Any method that calls
# split and iterates must not leave $_ in a modified state visible to the caller.
subtest '$_: not polluted by language() call' => sub {
local %ENV = (HTTP_ACCEPT_LANGUAGE => 'en,fr;q=0.9');
my $l = _obj([$LANG{EN}]);
local $_ = 'sentinel_value';
$l->language();
is($_, 'sentinel_value', '$_ unchanged after language()');
};
subtest '$_: not polluted by sublanguage() call' => sub {
local %ENV = (HTTP_ACCEPT_LANGUAGE => $LANG{EN_GB});
my $l = _obj([$LANG{EN_GB}]);
local $_ = 'sentinel_value';
$l->sublanguage();
is($_, 'sentinel_value', '$_ unchanged after sublanguage()');
};
subtest '$_: not polluted by locale() foreach loop' => sub {
local %ENV = (HTTP_USER_AGENT => 'Mozilla/5.0 (en-GB; rv:109.0) Gecko/20100101');
delete local $ENV{REMOTE_ADDR};
my $l = _obj([$LANG{EN}]);
local $_ = 'sentinel_value';
$l->locale();
is($_, 'sentinel_value', '$_ unchanged after locale() foreach loop');
};
subtest '$_: not polluted by country() call' => sub {
local %ENV = (GEOIP_COUNTRY_CODE => $CC_GB);
my $l = _obj([$LANG{EN}]);
local $_ = 'sentinel_value';
$l->country();
is($_, 'sentinel_value', '$_ unchanged after country()');
};
skip 'FIXME: find another EU IP address', 6 if(defined($l->country()) && ($l->country() eq 'ke'));
skip 'FIXME: find another EU IP address', 6 if(defined($l->country()) && ($l->country() eq 'nl'));
ok(defined($l->country()));
ok($l->country() eq 'Unknown');
ok($l->language_code_alpha2() eq 'en');
ok($l->language() eq 'English');
ok(defined($l->requested_language()));
ok($l->requested_language() eq 'English');
}
ok(!defined($l->sublanguage()));
# diag($l->locale());
}
t/extended_tests.t view on Meta::CPAN
# â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•
# SECTION 2: _find_language_from_ip() internal branches
#
# Strategy: force country() to return undef and exercise the LANG env-var
# fallback, the cache-hit branch, and the various Locale::Language code paths.
# â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•
subtest '_find_language_from_ip: country undef, LANG=en_US derives country US' => sub {
# When no geo data is available, _find_language_from_ip() calls _what_language()
# and extracts the country code from a POSIX locale string (xx_YY).
local %ENV = (LANG => 'en_US.UTF-8');
delete local $ENV{HTTP_ACCEPT_LANGUAGE};
delete local $ENV{REMOTE_ADDR};
delete local $ENV{LANGUAGE};
delete local $ENV{LC_ALL};
delete local $ENV{LC_MESSAGES};
# 'en' is supported; US English is the official US language, so the IP
# fallback should resolve English via the LANG-derived country 'US'.
my $l = _obj([$LANG{EN}]);
t/extended_tests.t view on Meta::CPAN
'time_zone() returns undef when no LWP present');
ok((grep { (ref $_ ? ($_->{warning} // '') : ($_ // '')) =~ /LWP/ } @warnings),
'time_zone() warns about missing LWP');
Test::Mockingbird::restore_all();
_block_network();
}
};
# â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•
# SECTION 9: locale() — User-Agent parsing branches
# â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•
subtest 'locale: User-Agent with xx-xx parenthetical resolves country' => sub {
# locale() first tries to extract a "xx-XX" tag from inside parens in the UA.
# e.g. "Mozilla/5.0 (en-US; ...)" → tries _code2country('us').
local %ENV = (
HTTP_USER_AGENT => 'Mozilla/5.0 (en-US; Linux x86_64)',
REMOTE_ADDR => $IP{LOOPBACK},
);
my $l = _obj([$LANG{EN}]);
my $loc;
lives_ok { $loc = $l->locale() } 'locale() with xx-XX in UA does not crash';
diag("locale from UA: " . (defined $loc ? ref($loc) : 'undef')) if $ENV{TEST_VERBOSE};
# Whether it resolves depends on Locale::Object::Country being installed.
ok(1, 'locale() ran without dying for UA with xx-XX pattern');
};
subtest 'locale: UA with no country pattern falls through to IP' => sub {
# A UA string without a parseable country code inside parens forces locale()
# to skip the UA path and proceed to the IP-address path.
local %ENV = (
HTTP_USER_AGENT => 'curl/7.68.0',
GEOIP_COUNTRY_CODE => 'DE',
);
delete local $ENV{REMOTE_ADDR};
my $l = _obj([$LANG{EN}]);
my $loc = $l->locale();
# If Locale::Object is installed, locale() should find DE via GEOIP_COUNTRY_CODE.
if(defined $loc) {
isa_ok($loc, 'Locale::Object::Country', 'locale() resolved from GEOIP fallback');
} else {
pass('locale() returned undef (Locale::Object DB may be absent)');
}
};
subtest 'locale: HTTP::BrowserDetect branch attempted after UA-parse fails' => sub {
SKIP: {
skip 'HTTP::BrowserDetect not installed', 1
unless eval { require HTTP::BrowserDetect; 1 };
# A UA that HTTP::BrowserDetect can parse for country but our simple regex
# does not match. Use a generic UA without xx-XX in the parenthetical.
local %ENV = (
HTTP_USER_AGENT => 'Mozilla/5.0 (Windows NT 10.0; Win64; x64)',
REMOTE_ADDR => $IP{LOOPBACK},
);
delete local $ENV{GEOIP_COUNTRY_CODE};
my $l = _obj([$LANG{EN}]);
my $loc;
lives_ok { $loc = $l->locale() } 'locale() with HTTP::BrowserDetect does not crash';
diag("BrowserDetect locale: " . (defined $loc ? ref $loc : 'undef')) if $ENV{TEST_VERBOSE};
ok(1, 'HTTP::BrowserDetect branch reached without crash');
}
};
# â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•
# SECTION 10: country() — _handle_eu_country via the second EU check
#
# After geo lookups, country() normalises the result. If _country eq 'eu'
# AFTER the first clean (which deleted 'eu' from IP::Country), it means a
# different geo module returned 'eu'. The second check calls _handle_eu_country.
t/function.t view on Meta::CPAN
my @carp_msgs;
# carp is now imported into CGI::Lingua at compile time (use Carp qw(carp)),
# so we must mock CGI::Lingua::carp — mocking Carp::carp would miss it.
Test::Mockingbird::mock('CGI::Lingua', 'carp', sub { push @carp_msgs, $_[0] });
$l->_warn({ warning => 'carp test' });
ok((grep { /carp test/ } @carp_msgs), 'CGI::Lingua::carp called with message text');
ok((grep { $_->{message} =~ /carp test/ } @{$l->{messages}}), 'Message recorded internally');
Test::Mockingbird::restore_all();
};
# ── locale() ─────────────────────────────────────────────────────────────────
subtest 'locale: quick return when _locale already set' => sub {
local %ENV = ();
my $sentinel = bless {}, 'Locale::Object::Country';
my $l = _basic_obj();
$l->{_locale} = $sentinel;
is($l->locale(), $sentinel, 'Cached _locale returned immediately');
};
subtest 'locale: GEOIP_COUNTRY_CODE validated before use in locale()' => sub {
# The security fix from critique: locale() must apply the same ISO 3166-1
# check as country() — an invalid value must not be passed to _code2country.
local %ENV = (GEOIP_COUNTRY_CODE => 'NOT_CC');
my $l = _basic_obj();
my $called = 0;
Test::Mockingbird::mock('CGI::Lingua', '_code2country', sub { $called = 1; undef });
$l->locale();
is($called, 0, 'Invalid GEOIP_COUNTRY_CODE not passed to _code2country');
Test::Mockingbird::restore_all();
};
subtest 'locale: valid GEOIP_COUNTRY_CODE used after validation' => sub {
# The security fix: a well-formed GEOIP_COUNTRY_CODE must reach _code2country.
# We inject a fake country object and confirm it is returned from locale().
local %ENV = (GEOIP_COUNTRY_CODE => 'GB', REMOTE_ADDR => '127.0.0.1');
my $fake_country = bless {}, 'Locale::Object::Country';
my $called = 0;
Test::Mockingbird::mock('CGI::Lingua', '_code2country', sub { $called = 1; $fake_country });
my $l = _basic_obj();
my $result = $l->locale();
ok($called, '_code2country was called for valid GEOIP_COUNTRY_CODE');
is($result, $fake_country, 'locale() returns the country object from _code2country');
Test::Mockingbird::restore_all();
};
# ── time_zone() ───────────────────────────────────────────────────────────────
subtest 'time_zone: quick return when _timezone cached' => sub {
local %ENV = (REMOTE_ADDR => '8.8.8.8');
my $l = _basic_obj();
$l->{_timezone} = 'America/New_York';
is($l->time_zone(), 'America/New_York', 'Cached timezone returned immediately');
#!perl -Tw
use strict;
use warnings;
use Test::More;
use CGI::Lingua;
# use Test::NoWarnings; # Win32::locale::Lexicon produces warnings
# Work around for systems with broken Module::Load
# http://www.cpantesters.org/cpan/report/eae7b808-172d-11e0-a672-41e7f2486b6f
use Test::Requires {
'Module::Load::Conditional' => 0.38
};
unless(-e 't/online.enabled') {
plan skip_all => 'On-line tests disabled';
} else {
t/hp-tablet.t view on Meta::CPAN
$ENV{'HTTP_USER_AGENT'} = 'Mozilla/5.0 (hp-tablet; Linux; hpwOS/3.0.2; U; en-NZ) AppleWebKit/534.6 (KHTML, like Gecko) wOSBrowser/234.40.1 Safari/534.6 TouchPad/1.0';
my $l = new_ok('CGI::Lingua' => [
supported => [ 'en-gb', 'da', 'fr', 'nl', 'de', 'it', 'cy', 'pt', 'pl', 'ja' ],
]);
ok(defined $l);
ok($l->isa('CGI::Lingua'));
TODO: {
local $TODO = 'https://github.com/oalders/http-browserdetect/issues/36';
ok(defined($l->code_alpha2()));
isa_ok($l->locale(), 'Locale::Object::Country');
SKIP: {
skip 'Test requires Internet access', 1 unless(-e 't/online.enabled');
ok(uc($l->locale()->code_alpha2()) eq 'NZ');
}
}
}
t/integration.t view on Meta::CPAN
# Strategy: feed real-world Accept-Language headers containing multiple candidates
# with quality weights. Vary the supported-languages list to exercise both
# "first match wins" and "sublanguage fallback" paths within a single request.
# â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•
subtest 'priority: de-DE,de;q=0.9,en-US;q=0.8,en;q=0.7 → German when de supported' => sub {
local %ENV = (
HTTP_ACCEPT_LANGUAGE => 'de-DE,de;q=0.9,en-US;q=0.8,en;q=0.7',
# No REMOTE_ADDR — prevent IP-based fallback from interfering
);
# Remove locale env vars that I18N::LangTags::Detect might consume
delete local $ENV{LANGUAGE};
delete local $ENV{LC_ALL};
delete local $ENV{LC_MESSAGES};
delete local $ENV{LANG};
my $l = _obj([$LANG{DE}, $LANG{EN}]);
is($l->language(), 'German', 'German selected as highest-priority supported language');
};
subtest 'priority: de-DE,de;q=0.9,en-US;q=0.8,en;q=0.7 → English (United States) when de not supported' => sub {
t/integration.t view on Meta::CPAN
my @calls = $whois_spy->();
ok(scalar @calls > 0,
'_resolve_country_via_whois attempted when IP::Country and geoplugin both fail');
{ local $SIG{__WARN__} = sub {}; Test::Mockingbird::restore_all() }
_block_network();
};
# â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•
# SECTION 10: GEOIP_COUNTRY_CODE coherence across country() and locale()
#
# Strategy: when the mod_geoip environment variable is set, country() and
# locale() must both derive from the same underlying code.
# â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•
subtest 'GEOIP_COUNTRY_CODE: country() and locale() agree on the same country' => sub {
local %ENV = (GEOIP_COUNTRY_CODE => 'GB');
my $l = _obj([$LANG{EN}]);
my $cc = $l->country();
is($cc, 'gb', 'country() returns gb from GEOIP_COUNTRY_CODE');
my $loc = $l->locale();
if(defined $loc) {
isa_ok($loc, 'Locale::Object::Country',
'locale() returns Locale::Object::Country');
} else {
pass('locale() returned undef (Locale::Object DB may be absent on this system)');
}
};
subtest 'HTTP_CF_IPCOUNTRY: country() and locale() agree when Cloudflare header set' => sub {
local %ENV = (HTTP_CF_IPCOUNTRY => 'FR');
my $l = _obj([$LANG{FR}, $LANG{EN}]);
is($l->country(), 'fr',
'country() returns fr from HTTP_CF_IPCOUNTRY');
my $loc = $l->locale();
if(defined $loc) {
isa_ok($loc, 'Locale::Object::Country',
'locale() returns Locale::Object::Country for FR');
} else {
pass('locale() returned undef (Locale::Object DB may be absent)');
}
};
# â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•
# SECTION 11: End-to-end session workflow
#
# Strategy: simulate a complete web request lifecycle where language, country,
# locale, and time_zone are all queried in sequence for the same object.
# Verify that each method returns a coherent result and that the object's
# internal state remains consistent after each call.
# â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•
subtest 'full session workflow: language + country + locale coherent with GEOIP_COUNTRY_CODE' => sub {
local %ENV = (
GEOIP_COUNTRY_CODE => 'GB',
HTTP_ACCEPT_LANGUAGE => $LANG{EN_GB},
);
my $l = _obj([$LANG{EN_GB}]);
my $lang = $l->language();
my $cc = $l->country();
my $loc = $l->locale();
is($lang, 'English', 'language() returns English');
is($cc, 'gb', 'country() returns gb');
if(defined $loc) {
isa_ok($loc, 'Locale::Object::Country',
'locale() returns Locale::Object::Country');
} else {
pass('locale() undef (Locale::Object DB absent — acceptable in CI)');
}
# Internal state: language and country must both be populated without
# interfering with each other — they populate different keys.
is($l->{_slanguage}, 'English', '_slanguage populated');
is($l->{_country}, 'gb', '_country populated');
};
subtest 'full session workflow: time_zone with cached _timezone skips all network I/O' => sub {
# If _timezone is already set (from a prior call or thawed cache), the method
t/language.t view on Meta::CPAN
if($l->language() ne 'English') {
diag('Expected English got "', $l->requested_language(), '"');
}
ok($l->name() eq 'English');
ok(defined $l->requested_language());
if($l->requested_language() !~ /English/) {
diag('Expected English requested language, got "', $l->requested_language(), '"');
}
ok($l->requested_language() =~ /English/);
ok($l->country() eq 'gb');
ok($l->locale()->code_alpha2() eq 'gb');
delete($ENV{'REMOTE_ADDR'});
$ENV{'HTTP_ACCEPT_LANGUAGE'} = 'en';
$l = new_ok('CGI::Lingua' => [
supported => ['en', 'en-gb', 'fr']
]);
ok($l->language() eq 'English');
ok(defined($l->requested_language()));
ok($l->requested_language() eq 'English');
ok(!defined($l->sublanguage()));
t/language.t view on Meta::CPAN
ok(defined $l);
ok($l->isa('CGI::Lingua'));
ok($l->language() eq 'Unknown');
ok(defined($l->requested_language()));
ok(!defined($l->language_code_alpha2()));
ok(!defined($l->sublanguage_code_alpha2()));
ok($l->country() eq 'no');
if($l->country() ne 'no') {
diag('Expected no got "', $l->country(), '"');
}
ok($l->locale()->code_alpha2() eq 'no');
delete($ENV{'HTTP_ACCEPT_LANGUAGE'});
{
delete local $ENV{'GEOIP_COUNTRY_CODE'};
delete local $ENV{'HTTP_CF_IPCOUNTRY'};
local $ENV{'REMOTE_ADDR'} = 'a.b.c.d';
$l = new_ok('CGI::Lingua' => [
supported => ['en', 'fr'],
]);
# Force the logger, in case a logger is defined in a config file that Config::Abstraction reads
if($^O eq 'MSWin32') {
$ENV{'IGNORE_WIN32_LOCALE'} = 1;
}
delete $ENV{'HTTP_ACCEPT_LANGUAGE'};
delete $ENV{'REMOTE_ADDR'};
$ENV{'HTTP_USER_AGENT'} = 'Mozilla/5.0 (Macintosh; U; Intel Mac OS X 10.6; en-US; rv:1.9.2.19) Gecko/20110707 Firefox/3.6.19';
my $l = new_ok('CGI::Lingua' => [
supported => ['en', 'en-us']
]);
ok(defined($l->locale()));
ok(defined($l->locale()->currency()));
ok($l->locale()->currency()->code() eq 'USD');
$ENV{'REMOTE_ADDR'} = '212.159.106.41';
$ENV{'HTTP_USER_AGENT'} = 'Mozilla/4.0 (compatible; MSIE 8.0; Windows NT 5.1; Trident/4.0; .NET CLR 1.0.3705; .NET CLR 1.1.4322; Media Center PC 4.0; .NET CLR 2.0.50727; .NET CLR 3.0.4506.2152; .NET CLR 3.5.30729; .NET4.0C; .NET4.0E)';
$l = new_ok('CGI::Lingua' => [
supported => ['en', 'en-gb']
]);
ok(defined($l->locale()));
isa_ok($l->locale(), 'Locale::Object::Country');
ok($l->locale()->currency()->code() eq 'GBP');
ok(uc($l->locale()->code_alpha2()) eq 'GB');
my @l = $l->locale()->languages_official();
ok(uc($l[0]->code_alpha2()) eq 'EN');
ok(uc($l->locale()->code_alpha2()) eq 'GB');
delete $ENV{'REMOTE_ADDR'};
$ENV{'HTTP_USER_AGENT'} = 'Java';
$l = new_ok('CGI::Lingua' => [
supported => ['en', 'en-us']
]);
ok(!defined($l->locale()));
# Asking for French in the US should return US locale
$ENV{'HTTP_ACCEPT_LANGUAGE'} = 'fr';
$ENV{'REMOTE_ADDR'} = '74.92.149.57';
$ENV{'HTTP_USER_AGENT'} = 'Mozilla/5.0 (Macintosh; U; Intel Mac OS X 10.7; en-US; rv:1.9.2.22) Gecko/20110902 Firefox/3.6.22';
$l = new_ok('CGI::Lingua' => [
supported => ['en', 'nl', 'fr', 'de', 'id', 'il', 'ja', 'ko', 'pt', 'ru', 'es', 'tr']
]);
ok(defined($l->locale()));
isa_ok($l->locale(), 'Locale::Object::Country');
ok(uc($l->locale()->code_alpha2()) eq 'US');
ok(defined($l->locale()->currency()));
ok($l->locale()->currency()->code() eq 'USD');
# User agent doesn't contain a location
$ENV{'REMOTE_ADDR'} = '81.145.173.18';
$ENV{'HTTP_USER_AGENT'} = 'Mozilla/4.0 (compatible; MSIE 8.0; Windows NT 5.2; WOW64; Trident/4.0; .NET CLR 1.1.4322; .NET CLR 2.0.50727; .NET CLR 3.0.04506.30; .NET CLR 3.0.04506.648; .NET CLR 3.5.21022; MS-RTC LM 8; .NET CLR 3.0.4506.2152; .NET CLR...
$ENV{'HTTP_ACCEPT_LANGUAGE'} = 'en-gb';
$l = new_ok('CGI::Lingua' => [
supported => ['en', 'en-gb']
]);
ok(defined($l->locale()));
isa_ok($l->locale(), 'Locale::Object::Country');
ok($l->locale()->currency()->code() eq 'GBP');
ok(uc($l->locale()->code_alpha2()) eq 'GB');
@l = $l->locale()->languages_official();
ok(uc($l[0]->code_alpha2()) eq 'EN');
ok(uc($l->locale()->code_alpha2()) eq 'GB');
$ENV{'HTTP_USER_AGENT'} = 'foo';
$l = new_ok('CGI::Lingua' => [
supported => ['en', 'en-gb']
]);
ok(defined($l->locale()));
isa_ok($l->locale(), 'Locale::Object::Country');
ok($l->locale()->currency()->code() eq 'GBP');
ok(uc($l->locale()->code_alpha2()) eq 'GB');
@l = $l->locale()->languages_official();
ok(uc($l[0]->code_alpha2()) eq 'EN');
ok(uc($l->locale()->code_alpha2()) eq 'GB');
$ENV{'HTTP_ACCEPT_LANGUAGE'} = 'en-us';
$ENV{'REMOTE_ADDR'} = '81.158.123.118';
$ENV{'HTTP_USER_AGENT'} = 'Mozilla/5.0 (Macintosh; Intel Mac OS X 10_7_3) AppleWebKit/534.55.3 (KHTML, like Gecko) Version/5.1.5 Safari/534.55.3';
$l = new_ok('CGI::Lingua' => [
supported => [ 'en-gb', 'da', 'fr', 'nl', 'de', 'it', 'cy', 'pt', 'pl', 'ja' ],
]);
my $locale = $l->locale();
isa_ok($locale, 'Locale::Object::Country');
ok(uc($l->locale()->code_alpha2()) eq 'GB');
$ENV{'HTTP_ACCEPT_LANGUAGE'} = 'en-ca';
$ENV{'REMOTE_ADDR'} = '67.193.26.102';
$ENV{'HTTP_USER_AGENT'} = 'Mozilla/4.0 (compatible; MSIE 8.0; Windows NT 5.1; Trident/4.0; GTB7.3; .NET CLR 1.1.4322; .NET CLR 2.0.50727; .NET CLR 3.0.04506.30; .NET CLR 3.0.4506.2152; .NET CLR 3.5.30729; .NET4.0C; .NET4.0E)';
$l = new_ok('CGI::Lingua' => [
supported => [ 'en-gb' ]
]);
$locale = $l->locale();
isa_ok($locale, 'Locale::Object::Country');
ok(uc($l->locale()->code_alpha2()) eq 'CA');
# LAN address
$ENV{'REMOTE_ADDR'} = '192.168.1.2';
$l = new_ok('CGI::Lingua' => [
supported => [ 'en-gb' ]
]);
ok(!defined($l->locale()));
# Find nothing
delete $ENV{'REMOTE_ADDR'};
$l = new_ok('CGI::Lingua' => [
supported => [ 'en-gb', 'da', 'fr', 'nl', 'de', 'it', 'cy', 'pt', 'pl', 'ja' ],
]);
$locale = $l->locale();
ok(!defined($locale));
# Add GEOIP_COUNTRY_CODE and now something should be found
$ENV{'GEOIP_COUNTRY_CODE'} = 'GB';
$l = new_ok('CGI::Lingua' => [
supported => [ 'en-gb', 'da', 'fr', 'nl', 'de', 'it', 'cy', 'pt', 'pl', 'ja' ],
]);
$locale = $l->locale();
isa_ok($locale, 'Locale::Object::Country');
ok(uc($l->locale()->code_alpha2()) eq 'GB');
} else {
plan skip_all => 'On-line tests disabled';
}
t/locales.t view on Meta::CPAN
#!/usr/bin/env perl
# t/locales.t — CGI::Lingua locale coverage
# 1. Geographic (GeoIP): GB, US, FR, DE, CN — case, concurrency, caching
# 2. POSIX system locale: en_US.UTF-8, de_DE.UTF-8, ja_JP.UTF-8
use strict;
use warnings;
use POSIX qw(ENOENT);
use Test::Most;
use Test::Needs qw(CHI IP::Country);
use Test::Mockingbird;
use lib 't/lib';
t/locales.t view on Meta::CPAN
);
my $cache = CHI->new(driver => 'Memory', global => 0);
for my $case (@GEO_CASES) {
my ($ip, $cc, $lang, $supported, $expected_lang, $expected_country) = @{$case};
subtest "GeoIP: $cc ($expected_lang)" => sub {
Test::Mockingbird::mock('IP::Country::Fast', 'inet_atocc', sub { $cc });
# Clear LANG so _what_language() doesn't fall through to the system locale
# path and produce a different language than the HTTP header specifies.
local %ENV = (
REMOTE_ADDR => $ip,
HTTP_ACCEPT_LANGUAGE => $lang,
);
delete $ENV{LANG};
my $l = CGI::Lingua->new(supported => $supported, cache => $cache);
is($l->country(), $expected_country, "country() returns '$expected_country' for $cc");
is($l->language(), $expected_lang, "language() returns '$expected_lang' for $cc");
t/locales.t view on Meta::CPAN
my $first_calls = $call_count;
# Second instance with the same IP and cache — should not call inet_atocc again
my $second = CGI::Lingua->new(supported => ['en'], cache => $shared_cache);
$second->country();
is($call_count, $first_calls, 'inet_atocc not called again for cached IP');
Test::Mockingbird::restore_all();
};
# ── POSIX system locale subtests ──────────────────────────────────────────
# Test that CGI::Lingua returns consistent results regardless of LC_ALL.
# We deliberately do NOT use POSIX::strerror() — we source error strings
# directly from Perl's errno layer to avoid C-library divergence.
my @POSIX_LOCALES = (
'en_US.UTF-8',
'de_DE.UTF-8',
'ja_JP.UTF-8',
);
subtest 'POSIX locale independence' => sub {
for my $locale (@POSIX_LOCALES) {
subtest "Locale $locale" => sub {
local $ENV{LC_ALL} = $locale;
local $ENV{LANG} = $locale;
local $ENV{LC_CTYPE} = $locale;
delete $ENV{HTTP_ACCEPT_LANGUAGE};
delete $ENV{REMOTE_ADDR};
# Core language detection must be unaffected by system locale
local $ENV{HTTP_ACCEPT_LANGUAGE} = 'fr';
my $l = CGI::Lingua->new(supported => ['fr', 'en']);
is($l->language(), 'French', "language() returns 'French' under $locale");
# Error path: verify that the ENOENT message can be obtained
# from Perl's errno layer (not from POSIX::strerror) under all locales
local $! = ENOENT;
my $enoent_msg = "$!";
ok(length($enoent_msg) > 0, "ENOENT message is non-empty under $locale: $enoent_msg");
# Simulate a missing /etc/timezone by ensuring time_zone()
# can survive the absence gracefully (if REMOTE_ADDR is unset,
# it tries to read /etc/timezone or fall back to DateTime)
# We only verify it doesn't die; actual value depends on the host.
my $tz;
eval { $tz = $l->time_zone() };
ok(!$@, "time_zone() does not die under $locale (err: $@)");
};
}
};
# Verify that language names returned by CGI::Lingua are consistent
# regardless of system locale — they come from Locale::Language (not libc)
subtest 'Language names are locale-independent' => sub {
my %expected = (
en => 'English',
fr => 'French',
de => 'German',
ja => 'Japanese',
);
for my $locale (@POSIX_LOCALES) {
local $ENV{LC_ALL} = $locale;
local $ENV{LANG} = $locale;
for my $code (sort keys %expected) {
local $ENV{HTTP_ACCEPT_LANGUAGE} = $code;
delete $ENV{REMOTE_ADDR};
my $l = CGI::Lingua->new(supported => [$code]);
is(
$l->language(), $expected{$code},
"'$code' → '$expected{$code}' under $locale"
);
}
}
};
# ── LANG env-var fallback ────────────────────────────────────────────────────
# When there is no HTTP_ACCEPT_LANGUAGE and no REMOTE_ADDR (e.g. running from
# the command line), _what_language() falls back to $ENV{LANG}. Verify that
# a full POSIX locale string like "de_DE.UTF-8" is accepted (not rejected by
# the untainting regex) and that it produces a sensible language result.
subtest 'LANG env-var fallback: POSIX locale form is accepted and used' => sub {
local %ENV = ();
delete $ENV{HTTP_ACCEPT_LANGUAGE};
delete $ENV{REMOTE_ADDR};
$ENV{LANG} = 'de_DE.UTF-8';
# 'de' is the only supported language — language() must return German
# by detecting 'de' from the LANG string even without an HTTP header.
my $l = CGI::Lingua->new(supported => ['de', 'en']);
my $lang = $l->language();
# We can't guarantee a match because _what_language returns the raw LANG
# string 'de_DE.UTF-8', and _find_language passes it to I18N::AcceptLanguage
# which may or may not parse the POSIX form. What we DO guarantee:
# - language() does not die
# - the LANG string was not rejected by the untainting regex (a rejection
# would return undef from _what_language, making language() return Unknown)
ok(defined $lang, 'language() does not die when LANG is a POSIX locale string');
diag("LANG=de_DE.UTF-8 → language()='$lang'") if $ENV{TEST_VERBOSE};
};
# ── Croak message locale independence ────────────────────────────────────────
# CGI::Lingua's own Carp::croak messages must be in English regardless of the
# system locale. They are hardcoded string literals; this test catches any
# future regression where a message is accidentally sourced from libc/iconv.
subtest 'CGI::Lingua error messages are locale-independent' => sub {
for my $locale (@POSIX_LOCALES) {
subtest "Croak text under $locale" => sub {
local $ENV{LC_ALL} = $locale;
local $ENV{LANG} = $locale;
delete $ENV{HTTP_ACCEPT_LANGUAGE};
delete $ENV{REMOTE_ADDR};
my $err;
eval { CGI::Lingua->new(supported => undef) };
$err = $@;
like($err, qr/supported languages/i,
"'supported languages' message is in English under $locale");
};
}
};
done_testing();
t/mutant_killers.t view on Meta::CPAN
# This is a structural test: _have_geoip transitions from UNKNOWN to PRESENT or ABSENT.
local %ENV = ();
my $l = _obj([$LANG_EN]);
$l->{_have_geoip} = $GEO_UNKNOWN;
$l->_load_geoip(); # let it run (may set ABSENT if Geo::IP not installed)
ok($l->{_have_geoip} != $GEO_UNKNOWN,
'_load_geoip always resolves the sentinel (COND_INV_1319)');
};
# â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•
# SECTION 14: locale() (multiple mutants, lines 1351-1399)
# â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•
subtest 'locale: UA language tag resolves to Locale::Object::Country (1351,1356,1358,1360)' => sub {
# Kill COND_INV_1351: if(defined($agent) && $agent =~ /\((.+)\)/) → TRUE for UA with parens.
# Kill COND_INV_1356: if($candidate =~ /^[a-zA-Z]{2}-([a-zA-Z]{2})$/) → matches 'en-GB'.
# Kill COND_INV_1358: if(my $c = $self->_code2country($1)) → resolves 'GB'.
# Kill BOOL_NEGATE_1360: return $c → returns the object.
# Skip when Locale::Object's SQLite database is absent (common on Windows CI).
# _code2country() returns undef in that case so locale() cannot return a blessed object.
my $has_locale_db = eval {
require Locale::Object::DB;
Locale::Object::DB->new()->lookup(
table => 'country',
result_column => 'name',
search_column => 'code_alpha2',
value => 'gb'
);
1;
};
SKIP: {
skip 'Locale::Object database absent', 3 unless $has_locale_db;
local %ENV = (HTTP_USER_AGENT => 'Mozilla/5.0 (en-GB; rv:109.0) test');
delete local $ENV{REMOTE_ADDR};
my $l = _obj([$LANG_EN]);
my $loc = $l->locale();
ok(defined($loc), 'locale returns defined object from UA (COND_INV_1351)');
ok(blessed($loc), 'locale is a blessed object');
is($loc->name(), 'United Kingdom', 'locale resolved to UK (COND_INV_1356,1358,1360)');
}
};
subtest 'locale: UA with no matching language tag falls through (COND_INV_1356)' => sub {
# A UA with parenthetical but no xx-XX pattern should not match the regex.
local %ENV = (HTTP_USER_AGENT => 'Mozilla/5.0 (Windows NT 10.0; Win64) Gecko');
delete local $ENV{REMOTE_ADDR};
my $l = _obj([$LANG_EN]);
# No matching candidate → locale() may fall through to HTTP::BrowserDetect or IP path.
my $loc = $l->locale();
# We don't assert a specific value; just that it doesn't crash.
ok(1, 'UA with no xx-XX tag does not crash (COND_INV_1356 negative path)');
};
subtest 'locale: HTTP::BrowserDetect fallback (COND_INV_1366_4, COND_INV_1369_4, BOOL_NEGATE_1371_5)' => sub {
# Kill COND_INV_1366: if(eval { require HTTP::BrowserDetect }) → TRUE when installed.
# Kill COND_INV_1369: browser->country() returns a code → _code2country() resolves it.
# Kill BOOL_NEGATE_1371: return $c → returns the country object.
SKIP: {
skip 'HTTP::BrowserDetect not installed', 3 unless $HAS_BROWSER;
# Use a UA that HTTP::BrowserDetect recognises as having a country.
local %ENV = (HTTP_USER_AGENT => 'Mozilla/5.0 (compatible; Googlebot/2.1; +http://www.google.com/bot.html)');
delete local $ENV{REMOTE_ADDR};
my $l = _obj([$LANG_EN]);
my $loc = $l->locale();
# We can't guarantee a specific country, but it shouldn't crash.
ok(1, 'HTTP::BrowserDetect path does not crash (COND_INV_1366, COND_INV_1369)');
diag("BrowserDetect locale: " . (defined($loc) ? $loc->name : 'undef')) if $ENV{TEST_VERBOSE};
}
};
subtest 'locale: IP-based country path (COND_INV_1385_3, COND_INV_1386_4)' => sub {
# Kill COND_INV_1385: unless($@) → TRUE (no exception) → if($c) check.
# Kill COND_INV_1386: if($c) → TRUE when _code2country returns object.
SKIP: {
skip 'IP::Country required', 2 unless $HAS_IPCOUNTRY;
local %ENV = (REMOTE_ADDR => $IP_PUBLIC);
delete local $ENV{HTTP_USER_AGENT};
my $l = _obj([$LANG_EN]);
_inject_ipcountry($l, 'US');
my $loc = $l->locale();
ok(defined($loc), 'locale resolved from IP country (COND_INV_1385)');
ok(blessed($loc), 'locale is blessed object (COND_INV_1386)');
}
};
subtest 'locale: GEOIP_COUNTRY_CODE path (COND_INV_1395_2, COND_INV_1397_4, BOOL_NEGATE_1399_5)' => sub {
# Kill COND_INV_1395: if(defined GEOIP_COUNTRY_CODE) → TRUE.
# Kill COND_INV_1397: if(my $c = _code2country(lc($1))) → resolves 'GB'.
# Kill BOOL_NEGATE_1399: return $c → returns the country object.
# Skip when Locale::Object's SQLite database is absent (common on Windows CI).
my $has_locale_db = eval {
require Locale::Object::DB;
Locale::Object::DB->new()->lookup(
table => 'country',
result_column => 'name',
search_column => 'code_alpha2',
value => 'gb'
);
1;
};
SKIP: {
skip 'Locale::Object database absent', 2 unless $has_locale_db;
local %ENV = (GEOIP_COUNTRY_CODE => 'GB');
delete local $ENV{REMOTE_ADDR};
delete local $ENV{HTTP_USER_AGENT};
my $l = _obj([$LANG_EN]);
my $loc = $l->locale();
ok(defined($loc), 'locale via GEOIP_COUNTRY_CODE (COND_INV_1395)');
is($loc->name(), 'United Kingdom', 'GB resolved (COND_INV_1397, BOOL_NEGATE_1399)');
}
};
# â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•
# SECTION 15: time_zone() (multiple mutants, lines 1449-1496)
# â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•
subtest 'time_zone: Geo::IP sentinel check (NUM_BOUNDARY_1449_27_!=, NUM_BOUNDARY_1452_27_!=)' => sub {
# Kill NUM_BOUNDARY_1449: if(_have_geoip == GEO_UNKNOWN) → load geoip.
t/mutant_killers.t view on Meta::CPAN
# â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•
# SECTION 17: _code2country() — country-defined trace branch (COND_INV_1546_2)
# â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•â•
subtest '_code2country: returns country object regardless of _country state (COND_INV_1546_2)' => sub {
# The if($self->{_country}) at 1546 is a debug-trace branch only; the actual
# lookup always happens. Kill: verify return value in both states.
# Skip when Locale::Object's SQLite database is absent (common on Windows CI);
# _code2country() returns undef in that case.
my $has_locale_db = eval {
require Locale::Object::DB;
Locale::Object::DB->new()->lookup(
table => 'country',
result_column => 'name',
search_column => 'code_alpha2',
value => 'gb'
);
1;
};
SKIP: {
skip 'Locale::Object database absent', 3 unless $has_locale_db;
local %ENV = ();
my $l = _obj([$LANG_EN]);
$l->{_country} = 'gb';
my $c1 = $l->_code2country('gb');
ok(defined($c1), '_code2country returns object with _country set (COND_INV_1546 true)');
ok(blessed($c1), '_code2country is blessed');
delete $l->{_country};
my $c2 = $l->_code2country('gb');
t/rt86809.t view on Meta::CPAN
#!perl -Tw
# Sometimes IANA reports 185.10.104.194 as being in NL rather than in Hong Kong
use strict;
use warnings;
use Test::Most;
# use Test::NoWarnings; # Win32::locale::Lexicon produces warnings
use lib 't/lib';
use MyLogger;
eval 'use autodie qw(:all)'; # Test for open/close failures
# Work around for systems with broken Module::Load
# http://www.cpantesters.org/cpan/report/eae7b808-172d-11e0-a672-41e7f2486b6f
use Test::Requires {
'Module::Load::Conditional' => 0.38
};
sub { push @warnings, $_[1] });
my $l = _obj([$LANG{EN}]);
$l->country();
ok((grep { ref($_) ? $_->{warning} =~ /invalid/ : /invalid/ } @warnings),
'_warn called for invalid HTTP_CF_IPCOUNTRY');
Test::Mockingbird::restore_all();
Test::Mockingbird::mock('CGI::Lingua', '_resolve_country_via_whois', sub { });
Test::Mockingbird::mock('LWP::Simple::WithCache', 'get', sub { undef });
};
# ── locale() ─────────────────────────────────────────────────────────────────
# POD: Returns a Locale::Object::Country object, or undef.
subtest 'locale: returns Locale::Object::Country for well-known country code' => sub {
local %ENV = (REMOTE_ADDR => $IP{PUBLIC});
Test::Mockingbird::mock('IP::Country::Fast', 'inet_atocc', sub { 'GB' });
my $l = _obj([$LANG{EN}]);
$l->{_have_ipcountry} = 1;
$l->{_ipcountry} = bless {}, 'IP::Country::Fast';
$l->{_have_geoip} = 0;
$l->{_have_geoipfree} = 0;
my $locale = $l->locale();
if(defined $locale) {
isa_ok($locale, 'Locale::Object::Country',
'locale() returns Locale::Object::Country');
} else {
# Locale::Object::Country DB may not be installed; skip gracefully
pass('locale() returned undef (Locale::Object may not be installed)');
}
Test::Mockingbird::restore_all();
Test::Mockingbird::mock('CGI::Lingua', '_resolve_country_via_whois', sub { });
Test::Mockingbird::mock('LWP::Simple::WithCache', 'get', sub { undef });
};
subtest 'locale: returns undef when no country can be determined' => sub {
local %ENV = (REMOTE_ADDR => $IP{LOOPBACK});
my $l = _obj([$LANG{EN}]);
my $result = $l->locale();
ok(!defined $result, 'locale() returns undef when country unresolvable');
};
subtest 'locale: GEOIP_COUNTRY_CODE valid code used as fallback' => sub {
# POD describes GEOIP_COUNTRY_CODE as a fallback source for locale()
local %ENV = (GEOIP_COUNTRY_CODE => 'GB', REMOTE_ADDR => $IP{LOOPBACK});
my $l = _obj([$LANG{EN}]);
my $result = $l->locale();
if(defined $result) {
isa_ok($result, 'Locale::Object::Country',
'locale() used GEOIP_COUNTRY_CODE fallback');
} else {
pass('locale() gracefully undef (Locale::Object DB may be absent)');
}
};
subtest 'locale: GEOIP_COUNTRY_CODE invalid code not used' => sub {
# Same ISO 3166-1 validation as country() — invalid codes must be skipped.
local %ENV = (GEOIP_COUNTRY_CODE => 'NOT_A_CC');
my $called = 0;
Test::Mockingbird::mock('CGI::Lingua', '_code2country',
sub { $called++; undef });
my $l = _obj([$LANG{EN}]);
$l->locale();
is($called, 0, 'Invalid GEOIP_COUNTRY_CODE not passed to _code2country');
Test::Mockingbird::restore_all();
Test::Mockingbird::mock('CGI::Lingua', '_resolve_country_via_whois', sub { });
Test::Mockingbird::mock('LWP::Simple::WithCache', 'get', sub { undef });
};
subtest 'locale: cached _locale returned immediately on second call' => sub {
# locale() must not re-run detection once it has a result.
local %ENV = ();
my $sentinel = bless {}, 'Locale::Object::Country';
my $l = _obj([$LANG{EN}]);
$l->{_locale} = $sentinel;
is($l->locale(), $sentinel, 'Cached _locale returned without re-computation');
};
# ── time_zone() ───────────────────────────────────────────────────────────────
# POD: Returns IANA timezone name string, or undef.
subtest 'time_zone: cached value returned immediately on second call' => sub {
local %ENV = (REMOTE_ADDR => $IP{PUBLIC});
my $l = _obj([$LANG{EN}]);
$l->{_timezone} = 'America/New_York';
is($l->time_zone(), 'America/New_York', 'Cached _timezone returned');
$ENV{'REMOTE_ADDR'} = '95.147.222.177';
my $l = new_ok('CGI::Lingua' => [
supported => ['en-gb', 'da', 'fr', 'nl', 'de', 'it', 'cy', 'pt', 'pl', 'ja'],
cache => $cache
]);
ok(defined $l);
ok($l->isa('CGI::Lingua'));
SKIP: {
skip 'Test requires Internet access', 2 unless(-e 't/online.enabled');
ok($l->country() eq 'gb');
ok($l->locale()->code_alpha2() eq 'gb');
}
ok(defined($l->requested_language()));
cmp_ok($l->requested_language(), 'eq', 'English (United Kingdom)');
ok($l->language() eq 'English');
ok($l->sublanguage() eq 'United Kingdom');
ok($l->sublanguage_code_alpha2() eq 'gb');
$ENV{'HTTP_ACCEPT_LANGUAGE'} = 'en-GB';
$l = new_ok('CGI::Lingua' => [
supported => ['en-gb', 'da', 'fr', 'nl', 'de', 'it', 'cy', 'pt', 'pl', 'ja'],
cache => $cache
]);
ok(defined $l);
ok($l->isa('CGI::Lingua'));
SKIP: {
skip 'Test requires Internet access', 2 unless(-e 't/online.enabled');
ok($l->country() eq 'gb');
ok($l->locale()->code_alpha2() eq 'gb');
}
ok(defined($l->requested_language()));
ok($l->requested_language() eq 'English (United Kingdom)');
ok($l->language() eq 'English');
ok($l->sublanguage() eq 'United Kingdom');
$ENV{'HTTP_ACCEPT_LANGUAGE'} = 'en-US';
$l = new_ok('CGI::Lingua' => [
supported => ['en-us', 'da', 'fr', 'nl', 'de', 'it', 'cy', 'pt', 'pl', 'ja'],
cache => $cache
]);
ok(defined $l);
ok($l->isa('CGI::Lingua'));
SKIP: {
skip 'Test requires Internet access', 2 unless(-e 't/online.enabled');
ok($l->country() eq 'gb');
ok($l->locale()->code_alpha2() eq 'gb');
}
ok($l->sublanguage_code_alpha2() eq 'us');
ok(defined($l->requested_language()));
ok($l->requested_language() eq 'English (United States)');
ok($l->name() eq 'English');
ok($l->sublanguage() eq 'United States');
$ENV{'HTTP_ACCEPT_LANGUAGE'} = 'en';
$l = new_ok('CGI::Lingua' => [
supported => ['en-gb', 'da', 'fr', 'nl', 'de', 'it', 'cy', 'pt', 'pl', 'ja'],
cache => $cache
]);
ok(defined $l);
ok($l->isa('CGI::Lingua'));
SKIP: {
skip 'Test requires Internet access', 2 unless(-e 't/online.enabled');
ok($l->country() eq 'gb');
ok($l->locale()->code_alpha2() eq 'gb');
}
ok(defined($l->requested_language()));
ok($l->requested_language() eq 'English (United Kingdom)');
ok($l->language() eq 'English');
ok($l->sublanguage() eq 'United Kingdom');
$l = new_ok('CGI::Lingua' => [
supported => ['en', 'da', 'fr', 'nl', 'de', 'it', 'cy', 'pt', 'pl', 'ja'],
cache => $cache
]);
SKIP: {
skip 'Test requires Internet access', 2 unless(-e 't/online.enabled');
ok($l->country() eq 'gb');
ok($l->locale()->code_alpha2() eq 'gb');
}
ok(defined($l->requested_language()));
cmp_ok($l->requested_language(), 'eq', 'English', 'Requested language is English');
cmp_ok($l->language(), 'eq', 'English', 'Language is English');
ok(!defined($l->sublanguage()));
# We want US English, but only British English is served, return English
# but with no sublanguage support
$ENV{'HTTP_ACCEPT_LANGUAGE'} = 'en-us';
undef $l; # Try to force a DESTROY to test object caching
$l = new_ok('CGI::Lingua' => [
supported => ['en-gb'],
cache => $cache
]);
ok(defined $l);
isa_ok($l, 'CGI::Lingua');
SKIP: {
skip 'Test requires Internet access', 2 unless(-e 't/online.enabled');
ok($l->country() eq 'gb');
ok($l->locale()->code_alpha2() eq 'gb');
}
ok(defined($l->requested_language()));
ok($l->requested_language() eq 'English (United States)');
ok($l->preferred_language() eq 'English');
ok(!defined($l->sublanguage()));
}
ok(!defined($l->language_code_alpha2()));
ok($l->language() eq 'Unknown');
ok($l->requested_language() eq 'Unknown');
} else {
ok($l->language_code_alpha2() eq 'en');
ok($l->language() eq 'English');
ok($l->requested_language() eq 'English');
}
}
ok(!defined($l->sublanguage()));
# diag($l->locale());
}
( run in 2.969 seconds using v1.01-cache-2.11-cpan-a5162978ef8 )