view release on metacpan or  search on metacpan

t/extended_tests.t  view on Meta::CPAN

	SKIP: {
		skip 'Net::Whois::IP or Net::Whois::IANA not installed', 1
			unless eval { require Net::Whois::IP; require Net::Whois::IANA; 1 };

	Test::Mockingbird::unmock('CGI::Lingua', '_resolve_country_via_whois');
	# The eval inside _resolve_country_via_whois converts warns to dies.
	# When whoisip_query fires a warn, the eval catches it and falls through to IANA.
	Test::Mockingbird::mock('Net::Whois::IP', 'whoisip_query', sub {
		warn "Connection timeout\n";
		return undef;
	});

	my $mock_iana = bless {}, 'Net::Whois::IANA';
	Test::Mockingbird::mock('Net::Whois::IANA', 'new',         sub { $mock_iana });
	Test::Mockingbird::mock('Net::Whois::IANA', 'whois_query', sub { 1 });
	Test::Mockingbird::mock('Net::Whois::IANA', 'country',     sub { 'US' });

	local %ENV = ();
	my $l = _obj([$LANG{EN}]);
	$l->_resolve_country_via_whois($IP{PUBLIC});
	is($l->{_country}, 'US', 'warn-into-die in whoisip_query absorbed; IANA returns US');

	{ local $SIG{__WARN__} = sub {}; Test::Mockingbird::restore_all() }
	_block_network();
	} # SKIP
};

subtest '_resolve_country_via_whois: IANA country with comment stripped' => sub {
	SKIP: {
		skip 'Net::Whois::IP or Net::Whois::IANA not installed', 1
			unless eval { require Net::Whois::IP; require Net::Whois::IANA; 1 };

	Test::Mockingbird::unmock('CGI::Lingua', '_resolve_country_via_whois');
	# Net::Whois::IP returns undef; IANA returns "CA # comment"
	Test::Mockingbird::mock('Net::Whois::IP', 'whoisip_query', sub { undef });

	my $mock_iana = bless {}, 'Net::Whois::IANA';
	Test::Mockingbird::mock('Net::Whois::IANA', 'new',         sub { $mock_iana });
	Test::Mockingbird::mock('Net::Whois::IANA', 'whois_query', sub { 1 });
	Test::Mockingbird::mock('Net::Whois::IANA', 'country',     sub { "CA # Canada\r\n" });

	local %ENV = ();
	my $l = _obj([$LANG{EN}]);
	$l->_resolve_country_via_whois($IP{PUBLIC});
	is($l->{_country}, 'CA', 'IANA comment suffix stripped; CRLF stripped');

	{ local $SIG{__WARN__} = sub {}; Test::Mockingbird::restore_all() }
	_block_network();
	} # SKIP
};

# ═══════════════════════════════════════════════════════════════════════════════
# 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}]);
	my $lang = $l->language();
	diag("LANG=en_US derived language: $lang") if $ENV{TEST_VERBOSE};
	# We can't guarantee Locale::Object data is installed, so just verify no crash.
	ok(defined $lang, '_find_language_from_ip with LANG=en_US does not crash');
};

subtest '_find_language_from_ip: country undef, LANG=fr derives country fr' => sub {
	# A bare 2-char LANG (xx) matches the second regex: $c =~ /^(..)$/
	local %ENV = (LANG => 'fr');
	delete local $ENV{HTTP_ACCEPT_LANGUAGE};
	delete local $ENV{REMOTE_ADDR};

	my $l = _obj(['fr']);
	my $lang;
	lives_ok { $lang = $l->language() } 'No crash when LANG is bare 2-char code';
	diag("LANG=fr derived language: " . ($lang // 'undef')) if $ENV{TEST_VERBOSE};
};

subtest '_find_language_from_ip: language_name cache hit skips Locale::Object' => sub {
	# Seed the cache with language_name:us so the geo-name lookup is skipped.
	local %ENV = (REMOTE_ADDR => $IP{PUBLIC});
	delete local $ENV{HTTP_ACCEPT_LANGUAGE};

	my $cache = _fresh_cache();
	$cache->set($CACHE_NS . 'language_name:us', 'English=en', '1 month');

	my $l = _obj([$LANG{EN}], cache => $cache);
	_inject_ipcountry($l, 'US');

	my $code_called = 0;
	Test::Mockingbird::mock('Locale::Language', 'language2code',
		sub { $code_called++; 'en' });

	my $lang = $l->language();
	diag("language from cache-seeded IP: $lang") if $ENV{TEST_VERBOSE};

	{ local $SIG{__WARN__} = sub {}; Test::Mockingbird::restore_all() }
	_block_network();

	ok(defined $lang, 'Language resolved from seeded language_name cache');
};

subtest '_find_language_from_ip: fast path when no Accept-Language and language_code2 known' => sub {
	# When $http_accept_language is undef and language_code2 is available,
	# the fast path sets $code = $language_code2 directly (no Locale::Language call).
	local %ENV = (REMOTE_ADDR => $IP{PUBLIC});
	delete local $ENV{HTTP_ACCEPT_LANGUAGE};

	my $l = _obj([$LANG{EN}]);
	_inject_ipcountry($l, 'US');

t/extended_tests.t  view on Meta::CPAN

		Test::Mockingbird::mock('LWP::Simple::WithCache', 'get',
			sub { '<<<MALFORMED JSON' });

		my @warnings;
		Test::Mockingbird::mock('CGI::Lingua', '_warn',
			sub { push @warnings, $_[1] });

		my $l = _obj([$LANG{EN}]);
		$l->{_have_geoip} = $GEO_ABSENT;

		my $tz;
		lives_ok { $tz = $l->time_zone() } 'Malformed ip-api.com JSON does not crash';
		ok((grep { ref($_) ? ($_->{warning}//'') =~ /unparseable/i : /unparseable/i } @warnings),
			'_warn called for unparseable ip-api.com JSON');

		{ local $SIG{__WARN__} = sub {}; Test::Mockingbird::restore_all() }
		_block_network();
	}
};

# ═══════════════════════════════════════════════════════════════════════════════
# SECTION 8: time_zone() graceful degradation when neither LWP variant is installed
# ═══════════════════════════════════════════════════════════════════════════════

subtest 'time_zone: warns and returns undef when neither LWP variant present' => sub {
	# When both LWP::Simple::WithCache and LWP::Simple are unavailable AND
	# Geo::IP is absent, time_zone() must warn and return undef (graceful
	# degradation — it no longer croaks, which would kill the entire CGI request).
	local %ENV = (REMOTE_ADDR => $IP{PUBLIC});

	my $l = _obj([$LANG{EN}]);
	$l->{_have_geoip} = $GEO_ABSENT;

	# This branch is only reachable when both LWP variants are genuinely absent;
	# we cannot mock require() away, so skip when either is installed.
	SKIP: {
		skip 'LWP::Simple::WithCache IS installed — no-LWP branch not reachable', 1
			if $HAS_LWP;
		skip 'LWP::Simple is installed — no-LWP branch not reachable', 1
			if eval { require LWP::Simple; 1 };

		my @warnings;
		Test::Mockingbird::mock('CGI::Lingua', '_warn',
			sub { push @warnings, $_[1] });

		my $tz;
		lives_ok { $tz = $l->time_zone() }
			'time_zone() does not croak when no LWP present';
		ok(!defined $tz,
			'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.
# ═══════════════════════════════════════════════════════════════════════════════

subtest 'country: eu from Whois triggers _handle_eu_country' => sub {
	# Mock _resolve_country_via_whois to set _country = 'eu', then verify the
	# _handle_eu_country path fires and converts it to Unknown (for non-Baidu).
	local %ENV = (REMOTE_ADDR => $IP{PUBLIC});

	my $l = _obj([$LANG{EN}]);
	$l->{_have_ipcountry} = $GEO_ABSENT;
	$l->{_have_geoip}     = $GEO_ABSENT;
	$l->{_have_geoipfree} = $GEO_ABSENT;

	# Override the global no-op with one that sets _country = 'eu'
	Test::Mockingbird::mock('CGI::Lingua', '_resolve_country_via_whois',
		sub { $_[0]->{_country} = 'eu' });

	my $cc = $l->country();
	is($cc, 'Unknown', '"eu" from Whois is converted to Unknown by _handle_eu_country');

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

subtest 'country: eu from Whois for Baidu subnet maps to cn' => sub {
	# Same as above but using the Baidu IP — _handle_eu_country maps it to 'cn'.
	local %ENV = (REMOTE_ADDR => $IP{BAIDU});

	my $l = _obj([$LANG{EN}]);
	$l->{_have_ipcountry} = $GEO_ABSENT;
	$l->{_have_geoip}     = $GEO_ABSENT;
	$l->{_have_geoipfree} = $GEO_ABSENT;

	Test::Mockingbird::mock('CGI::Lingua', '_resolve_country_via_whois',
		sub { $_[0]->{_country} = 'eu' });

	my $cc = $l->country();
	is($cc, 'cn', 'Baidu subnet EU result mapped to cn via _handle_eu_country');

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

# ═══════════════════════════════════════════════════════════════════════════════
# SECTION 11: new() — ::new() call with no params at all
# ═══════════════════════════════════════════════════════════════════════════════

subtest 'new: ::new() with no arguments croaks' => sub {
	# Calling CGI::Lingua::new() with no arguments at all (not even undef) means
	# $class is undef and $params is undef.  The guard `if($params)` fails,
	# so we land on `$class = __PACKAGE__` and then croak for missing supported.