view release on metacpan or  search on metacpan

t/function.t  view on Meta::CPAN

subtest 'new: missing supported croaks' => sub {
	local %ENV = ();
	throws_ok { CGI::Lingua->new() } qr/^Usage|supported languages/i,
		'new() without supported croaks';
};

subtest 'new: wrong ref type for supported croaks' => sub {
	local %ENV = ();
	throws_ok {
		CGI::Lingua->new(supported => {})
	} qr/array ref/i, 'hashref supported croaks';
};

subtest 'new: string supported too short/long croaks' => sub {
	local %ENV = ();
	throws_ok { CGI::Lingua->new(supported => 'x') } qr/short code/i,
		'1-char supported croaks';
	throws_ok { CGI::Lingua->new(supported => 'toolong') } qr/short code/i,
		'7-char supported croaks';
};

subtest 'new: plain hashref logger accepted as Object::Configure config' => sub {
	# Object::Configure converts any non-blessed logger value (hashref, arrayref)
	# into a Log::Abstraction instance.  We must not pre-reject these.
	local %ENV = ();
	my $l;
	lives_ok { $l = CGI::Lingua->new(supported => ['en'], logger => {}) }
		'plain hashref logger does not croak — Object::Configure converts it';
	ok(blessed($l->{logger}), 'converted logger is a blessed object');
};

subtest 'new: invalid logger (missing method) croaks' => sub {
	local %ENV = ();
	# Object that has warn/info but not error
	my $partial = bless {}, 'PartialLogger';
	{
		no warnings 'once';
		*PartialLogger::warn = sub {};
		*PartialLogger::info = sub {};
	}
	throws_ok {
		CGI::Lingua->new(supported => ['en'], logger => $partial)
	} qr/blessed object/i, 'logger missing error() croaks';
};

subtest 'new: string supported wraps into arrayref' => sub {
	local %ENV = (HTTP_ACCEPT_LANGUAGE => 'fr');
	my $l = CGI::Lingua->new(supported => 'fr');
	ok(ref($l->{_supported}) eq 'ARRAY', '_supported is arrayref for string input');
	is_deeply($l->{_supported}, ['fr'], '_supported contains the single language');
};

subtest 'new: sentinel flags initialised to GEO_UNKNOWN' => sub {
	local %ENV = ();
	my $l = _basic_obj();
	is($l->{_have_ipcountry}, $GEO_UNKNOWN, '_have_ipcountry starts at -1');
	is($l->{_have_geoip},     $GEO_UNKNOWN, '_have_geoip starts at -1');
	is($l->{_have_geoipfree}, $GEO_UNKNOWN, '_have_geoipfree starts at -1');
};

subtest 'new: cloning overlays params onto existing state' => sub {
	local %ENV = (HTTP_ACCEPT_LANGUAGE => 'en');
	my $orig  = _basic_obj();
	$orig->{_country} = 'us';
	my $clone = $orig->new(supported => ['de']);
	is($clone->{_country}, 'us', 'Clone inherits computed state');
	is_deeply($clone->{_supported}, ['de'], 'Clone takes new supported');
	isnt($orig, $clone, 'Clone is a distinct object');
};

subtest 'new: cache restoration thaws frozen state' => sub {
	# The key bug this exercises: arrayref supported must build the same
	# cache key in new() as DESTROY() does, so the thaw path is reachable.
	local %ENV = (REMOTE_ADDR => '1.2.3.4', HTTP_ACCEPT_LANGUAGE => 'en');
	my $cache = _fresh_cache();
	my $first = CGI::Lingua->new(supported => ['en'], cache => $cache);
	$first->language();    # populate computed state
	undef $first;          # triggers DESTROY, writes to cache

	# Second construction for the same IP must restore from cache
	local $ENV{REMOTE_ADDR} = '1.2.3.4';
	my $second = CGI::Lingua->new(supported => ['en'], cache => $cache);
	is($second->{_slanguage}, 'English', 'Cached _slanguage is restored');
};

# ── _build_cache_key ─────────────────────────────────────────────────────────

subtest '_build_cache_key: string supported' => sub {
	local %ENV = ();
	my $key = CGI::Lingua::_build_cache_key('1.2.3.4', { supported => 'en' }, 'CGI::Lingua', undef);
	is($key, '1.2.3.4/en', 'Key is ip/lang for string supported');
};

subtest '_build_cache_key: arrayref supported produces deterministic key' => sub {
	# The original bug: ref($params->{'supported'} eq 'ARRAY') always
	# evaluated to '' so arrayrefs were stringified as ARRAY(0x...).
	local %ENV = ();
	my $supported = ['en', 'fr'];
	my $key = CGI::Lingua::_build_cache_key('1.2.3.4', { supported => $supported }, 'CGI::Lingua', undef);
	is($key, '1.2.3.4/en/fr', 'Arrayref supported gives joined key, not ARRAY(0x...)');
	unlike($key, qr/ARRAY\(/, 'Key does not contain stringified reference');
};

subtest '_build_cache_key: includes Accept-Language in key' => sub {
	local %ENV = (HTTP_ACCEPT_LANGUAGE => 'fr');
	my $key = CGI::Lingua::_build_cache_key('5.6.7.8', { supported => ['fr'] }, 'CGI::Lingua', undef);
	is($key, '5.6.7.8/fr/fr', 'Key embeds Accept-Language for distinct slots per-IP');
};

subtest '_build_cache_key: info->lang() takes priority over env var' => sub {
	local %ENV = (HTTP_ACCEPT_LANGUAGE => 'de');
	# Minimal mock info object
	my $info = bless {}, 'MockInfo';
	Test::Mockingbird::mock('MockInfo', 'lang', sub { 'ja' });
	my $key = CGI::Lingua::_build_cache_key('9.9.9.9', { supported => ['ja'] }, 'CGI::Lingua', $info);
	like($key, qr{^9\.9\.9\.9/ja/}, 'info->lang() overrides env HTTP_ACCEPT_LANGUAGE in key');
	Test::Mockingbird::restore_all();
};

# ── DESTROY ──────────────────────────────────────────────────────────────────