view release on metacpan or  search on metacpan

t/function.t  view on Meta::CPAN

	my $count_before = 0;
	eval { CGI::Lingua->_log('debug', 'test') };
	ok(!$@, '_log does not die when called as class method');
};

subtest '_log: no-op for empty message list' => sub {
	local %ENV = ();
	my $l = _basic_obj();
	my $count = scalar @{$l->{messages} // []};
	$l->_log('info');    # no messages
	is(scalar @{$l->{messages} // []}, $count, 'Empty _log does not append to messages');
};

# ── _debug / _info / _notice / _trace ─────────────────────────────────────────

subtest '_debug/_info/_notice/_trace delegate to _log with correct level' => sub {
	local %ENV = ();
	my $l = _basic_obj();

	for my $level (qw(debug info notice trace)) {
		my $method = "_$level";
		$l->$method("testing $level");
		is($l->{messages}[-1]{level}, $level, "_$level sets level to '$level'");
	}
};

# ── _warn ─────────────────────────────────────────────────────────────────────

subtest '_warn: with logger calls logger->warn() with extracted string' => sub {
	local %ENV = ();
	my $received;
	my $logger = bless {}, 'WarnLogger';
	{
		no warnings 'once';
		*WarnLogger::warn  = sub { $received = $_[1] };
		*WarnLogger::info  = sub {};
		*WarnLogger::error = sub {};
	}
	my $l = CGI::Lingua->new(supported => ['en'], logger => $logger);
	$l->_warn({ warning => 'something went wrong' });
	is($received, 'something went wrong', 'Logger receives the warning string');
	ok(!ref $received, 'Logger does not receive an arrayref (new normalised API)');
};

subtest '_warn: without logger appends to messages and carps' => sub {
	# Object::Configure always injects a Log::Abstraction logger, so we
	# must explicitly clear it to exercise the no-logger (Carp) branch.
	local %ENV = ();
	my $l = _basic_obj();
	$l->{logger} = undef;    # force the Carp::carp code path
	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');
};

subtest 'time_zone: invalid REMOTE_ADDR warns and returns undef' => sub {
	local %ENV = (REMOTE_ADDR => 'bad-addr');
	my $warned = 0;
	Test::Mockingbird::mock('CGI::Lingua', '_warn', sub { $warned = 1 });
	my $l = _basic_obj();
	my $result = $l->time_zone();
	ok($warned, '_warn fired for invalid REMOTE_ADDR in time_zone()');
	ok(!defined $result, 'undef returned for invalid IP in time_zone()');
	Test::Mockingbird::restore_all();
};

# ── Memory cycle tests ────────────────────────────────────────────────────────
# CGI::Lingua stores caches, loggers, and self-referential state.  Ensure
# none of these create reference cycles that would block garbage collection.

subtest 'No memory cycles in fresh object' => sub {
	local %ENV = ();
	my $l = _basic_obj();
	memory_cycle_ok($l, 'Fresh CGI::Lingua object has no cycles');
};

subtest 'No memory cycles after language() is called' => sub {
	local %ENV = (HTTP_ACCEPT_LANGUAGE => 'en');
	my $l = _basic_obj();
	$l->language();
	memory_cycle_ok($l, 'Object after language() has no cycles');
};

subtest 'No memory cycles in object with CHI cache' => sub {
	local %ENV = (HTTP_ACCEPT_LANGUAGE => 'fr');
	my $cache = _fresh_cache();
	my $l = CGI::Lingua->new(supported => ['fr'], cache => $cache);
	$l->language();
	memory_cycle_ok($l, 'Object with cache has no cycles after language()');
};

subtest 'No memory cycles in frozen DESTROY copy' => sub {
	local %ENV = (REMOTE_ADDR => '5.5.5.5', HTTP_ACCEPT_LANGUAGE => 'en');
	my $cache = _fresh_cache();
	{
		my $l = CGI::Lingua->new(supported => ['en'], cache => $cache);
		$l->language();
	}
	my $blob   = $cache->get('5.5.5.5/en/en');
	my $thawed = JSON::PP::decode_json($blob);
	memory_cycle_ok($thawed, 'Thawed DESTROY copy has no cycles');
};