view release on metacpan or  search on metacpan

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';

BEGIN { use_ok('CGI::Lingua') }

# ── Sanity: the GeoIP mock must be operational ────────────────────────────
# BAIL_OUT immediately if IP::Country::Fast isn't accessible — all
# geographic subtests below depend on it.
subtest 'GeoIP sanity' => sub {
	my $probed = 0;
	Test::Mockingbird::mock('IP::Country::Fast', 'inet_atocc', sub {
		$probed = 1;
		return 'GB';
	});
	local %ENV = (
		REMOTE_ADDR          => '1.2.3.4',
		HTTP_ACCEPT_LANGUAGE => 'en-gb',
	);
	my $l = CGI::Lingua->new(supported => ['en-gb']);
	$l->country();    # triggers the mock

	unless($probed) {
		Test::Mockingbird::restore_all();
		BAIL_OUT('IP::Country::Fast mock is not functioning — GeoIP tests cannot run');
	}
	Test::Mockingbird::restore_all();
	pass('GeoIP mock is operational');
};

# ── Geographic subtests ───────────────────────────────────────────────────

# Country-to-language table used by the geographic tests.
# Each entry: [ ip, mock_cc, accept_lang, supported, expected_language, expected_country ]
my @GEO_CASES = (
	[ '1.2.3.4',   'GB', 'en-gb',  ['en', 'en-gb'], 'English',  'gb' ],
	[ '8.8.8.8',   'US', 'en-us',  ['en', 'en-us'], 'English',  'us' ],
	[ '90.0.0.1',  'FR', 'fr',     ['fr', 'en'],    'French',   'fr' ],
	[ '80.0.0.1',  'DE', 'de',     ['de', 'en'],    'German',   'de' ],
	[ '1.180.0.1', 'CN', 'zh-cn',  ['zh', 'en'],    'Chinese',  'cn' ],
);

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");

		Test::Mockingbird::restore_all();
	};
}

# Case-insensitivity: uppercase Accept-Language should match the same way
subtest 'Case insensitivity — EN-GB' => sub {
	Test::Mockingbird::mock('IP::Country::Fast', 'inet_atocc', sub { 'GB' });

	local %ENV = (
		REMOTE_ADDR          => '1.2.3.4',
		HTTP_ACCEPT_LANGUAGE => 'EN-GB',    # uppercase
	);
	delete $ENV{LANG};

	my $l = CGI::Lingua->new(supported => ['en-gb']);
	is($l->sublanguage_code_alpha2(), 'gb', 'Uppercase Accept-Language handled correctly');
	Test::Mockingbird::restore_all();
};

# Concurrent instances must not share state through the cache or globals.
# country() reads $ENV{REMOTE_ADDR} lazily at call time, so we must keep the
# correct REMOTE_ADDR in scope when calling country() on each object.  Both
# objects are kept alive simultaneously (declared in the outer scope) to verify
# true concurrent isolation — neither touches the other's _country field.
subtest 'Concurrent instances do not share state' => sub {
	Test::Mockingbird::mock('IP::Country::Fast', 'inet_atocc', sub {
		my ($self_mock, $ip) = @_;
		return $ip =~ /^8\.8/ ? 'US' : 'FR';
	});

	local %ENV = (HTTP_ACCEPT_LANGUAGE => 'en');

	# Create and immediately resolve each object while its REMOTE_ADDR is live.
	# $us and $fr are declared in the outer scope so both remain alive together.
	my ($us, $us_cc);
	{ local $ENV{REMOTE_ADDR} = '8.8.8.8';
	  $us    = CGI::Lingua->new(supported => ['en', 'fr']);
	  $us_cc = $us->country(); }

	my ($fr, $fr_cc);
	{ local $ENV{REMOTE_ADDR} = '90.0.0.1';
	  $fr    = CGI::Lingua->new(supported => ['en', 'fr']);
	  $fr_cc = $fr->country(); }

	# Both objects are live here — verify they hold independent state.
	is($us_cc,  'us', 'US IP resolves to us');
	is($fr_cc,  'fr', 'FR IP resolves to fr');
	isnt($us_cc, $fr_cc, 'Different IPs resolve to different countries');
	Test::Mockingbird::restore_all();
};

# Cache: a second lookup for the same IP should hit the cache
subtest 'Country result is cached between instances' => sub {
	my $call_count = 0;
	Test::Mockingbird::mock('IP::Country::Fast', 'inet_atocc', sub {
		$call_count++;
		return 'US';
	});

	my $shared_cache = CHI->new(driver => 'Memory', global => 0);

	local %ENV = (
		REMOTE_ADDR          => '4.4.4.4',
		HTTP_ACCEPT_LANGUAGE => 'en',
	);

	my $first  = CGI::Lingua->new(supported => ['en'], cache => $shared_cache);
	$first->country();
	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();