view release on metacpan or  search on metacpan

t/edge_cases.t  view on Meta::CPAN

		sub { push @warnings, $_[1] });
	my $l = _obj([$LANG{EN}]);
	$l->language();
	ok((grep { ref($_) ? $_->{warning} =~ /invalid/i : /invalid/i } @warnings),
		"SQL injection payload is rejected");
	Test::Mockingbird::restore_all();
	_block_network();
};

subtest 'HTTP_ACCEPT_LANGUAGE: newline embedded in header is rejected (log-injection guard)' => sub {
	# \n IS in \s, which is in the character class, so a naive test might
	# accept it.  However the `/a` flag combined with $ (end-anchor without
	# /m) means that the character-class capture must consume the ENTIRE string
	# (including the second line).  The colon in "X-Header: value" is NOT in
	# the class, so multi-line injection payloads are rejected.
	local %ENV = (
		HTTP_ACCEPT_LANGUAGE => "en\nX-Injected-Header: value",
		REMOTE_ADDR          => $IP{LOOPBACK},
	);
	my @warnings;
	Test::Mockingbird::mock('CGI::Lingua', '_warn',
		sub { push @warnings, $_[1] });
	my $l = _obj([$LANG{EN}]);
	$l->language();
	ok((grep { ref($_) ? $_->{warning} =~ /invalid/i : /invalid/i } @warnings),
		'Header-injection payload with colon is rejected');
	Test::Mockingbird::restore_all();
	_block_network();
};

subtest 'HTTP_ACCEPT_LANGUAGE: Unicode content rejected by /a flag' => sub {
	# The /a flag restricts \w, \d, \s to ASCII-only, blocking multi-byte
	# Unicode that would otherwise match [A-Za-z0-9].
	# Setting Unicode in %ENV produces a "Wide character in setenv" warning on
	# some platforms; suppress it so the test is portable.
	local %ENV = (REMOTE_ADDR => $IP{LOOPBACK});
	{ local $SIG{__WARN__} = sub {};
	  $ENV{HTTP_ACCEPT_LANGUAGE} = "zh-\x{4e2d}\x{6587}" }    # zh-中文

	my @warnings;
	Test::Mockingbird::mock('CGI::Lingua', '_warn',
		sub { push @warnings, $_[1] });
	my $l = _obj([$LANG{EN}]);
	$l->language();
	ok((grep { ref($_) ? $_->{warning} =~ /invalid/i : /invalid/i } @warnings),
		'Unicode in Accept-Language is rejected (ASCII-only mode)');
	Test::Mockingbird::restore_all();
	_block_network();
};

# ═══════════════════════════════════════════════════════════════════════════════
# SECTION 3: REMOTE_ADDR injection and boundary conditions
#
# Strategy: probe the IP-validation regex
#   IPv4: /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/a
#   IPv6: /^([0-9a-fA-F:]{2,39})$/a
# and the subsequent Data::Validate::IP checks.
# ═══════════════════════════════════════════════════════════════════════════════

subtest 'REMOTE_ADDR: command injection rejected before any geo lookup' => sub {
	# The semicolon is not in either IP regex, so this is blocked at the
	# untaint step — no geo module or shell is ever called.
	local %ENV = (REMOTE_ADDR => '8.8.8.8;rm -rf /');
	my @warnings;
	Test::Mockingbird::mock('CGI::Lingua', '_warn',
		sub { push @warnings, $_[1] });
	my $l = _obj([$LANG{EN}]);
	my $cc = $l->country();
	ok(!defined $cc, 'Command-injection REMOTE_ADDR returns undef');
	ok((grep { ref($_) ? $_->{warning} =~ /valid IP/i : /valid IP/i } @warnings),
		'_warn fired for injection attempt in REMOTE_ADDR');
	Test::Mockingbird::restore_all();
	_block_network();
};

subtest 'REMOTE_ADDR: path traversal rejected' => sub {
	local %ENV = (REMOTE_ADDR => '../etc/passwd');
	my $l = _obj([$LANG{EN}]);
	ok(!defined $l->country(), 'Path traversal REMOTE_ADDR returns undef');
};

subtest 'REMOTE_ADDR: out-of-range octet handled by Data::Validate::IP' => sub {
	# "999.1.1.1" matches \d{1,3} (each octet can be 1-3 digits) but
	# Data::Validate::IP::is_ipv4 rejects octets > 255.
	local %ENV = (REMOTE_ADDR => '999.1.1.1');
	my @warnings;
	Test::Mockingbird::mock('CGI::Lingua', '_warn',
		sub { push @warnings, $_[1] });
	my $l = _obj([$LANG{EN}]);
	my $cc = $l->country();
	ok(!defined $cc,
		'Out-of-range octet address returns undef');
	Test::Mockingbird::restore_all();
	_block_network();
};

subtest 'REMOTE_ADDR: SQL injection in IP field rejected' => sub {
	local %ENV = (REMOTE_ADDR => "1.2.3.4'; DROP TABLE users--");
	my @warnings;
	Test::Mockingbird::mock('CGI::Lingua', '_warn',
		sub { push @warnings, $_[1] });
	my $l = _obj([$LANG{EN}]);
	ok(!defined $l->country(), 'SQL injection in REMOTE_ADDR returns undef');
	Test::Mockingbird::restore_all();
	_block_network();
};

subtest 'REMOTE_ADDR: very long string is rejected before geo lookup' => sub {
	# An overlong string cannot match the tightly-bounded IPv4/IPv6 patterns.
	local %ENV = (REMOTE_ADDR => ('1' x 1000) . '.1.1.1');
	my $l = _obj([$LANG{EN}]);
	ok(!defined $l->country(), 'Overlong REMOTE_ADDR returns undef without crash');
};

subtest 'REMOTE_ADDR: IPv6 injection with trailing semicolon rejected' => sub {
	# Semicolon is not in [0-9a-fA-F:], so this never makes it to geo lookup.
	local %ENV = (REMOTE_ADDR => '2001:db8::1;ls');
	my @warnings;
	Test::Mockingbird::mock('CGI::Lingua', '_warn',
		sub { push @warnings, $_[1] });
	my $l = _obj([$LANG{EN}]);

t/edge_cases.t  view on Meta::CPAN

	_block_network();
};

# ═══════════════════════════════════════════════════════════════════════════════
# SECTION 6: Upstream geo-lookup failure returns
#
# Strategy: mock IP::Country to return every documented "bad" value and verify
# that country() handles each gracefully — warning where documented, returning
# the right remapped value, or falling through to the next geo module.
# ═══════════════════════════════════════════════════════════════════════════════

subtest 'geo: IP::Country returns undef — country() falls through' => sub {
	local %ENV = (REMOTE_ADDR => $IP{PUBLIC});
	my $l = _obj([$LANG{EN}]);
	_inject_ipcountry($l, undef);
	# No subsequent geo module is available — should reach whois (mocked no-op).
	my $cc = $l->country();
	ok(!defined $cc, 'country() returns undef when IP::Country returns undef and fallbacks empty');
	{ local $SIG{__WARN__} = sub {}; Test::Mockingbird::restore_all() }
	_block_network();
};

subtest 'geo: IP::Country returns empty string — treated as undef' => sub {
	local %ENV = (REMOTE_ADDR => $IP{PUBLIC});
	my $l = _obj([$LANG{EN}]);
	_inject_ipcountry($l, '');
	my $cc = $l->country();
	ok(!defined $cc || $cc eq '',
		'Empty string from IP::Country does not crash country()');
	{ local $SIG{__WARN__} = sub {}; Test::Mockingbird::restore_all() }
	_block_network();
};

subtest 'geo: IP::Country returns numeric "1" — discarded with warning' => sub {
	# POD message: "IP matches to a numeric country"
	local %ENV = (REMOTE_ADDR => $IP{PUBLIC});
	my @warnings;
	Test::Mockingbird::mock('CGI::Lingua', '_warn',
		sub { push @warnings, $_[1] });

	my $l = _obj([$LANG{EN}]);
	_inject_ipcountry($l, '1');
	my $cc = $l->country();

	ok(!defined $cc, 'Numeric country from IP::Country returns undef');
	ok((grep { ref($_) ? $_->{warning} =~ /numeric/i : /numeric/i } @warnings),
		'Warning fired for numeric country from IP::Country');

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

subtest 'geo: IP::Country returns "eu" — deleted, falls through' => sub {
	# The module discards "eu" because it is not a real country code.
	local %ENV = (REMOTE_ADDR => $IP{PUBLIC});

	my $l = _obj([$LANG{EN}]);
	_inject_ipcountry($l, 'EU');
	my $cc = $l->country();

	# After EU is discarded, fallbacks are all blocked — undef expected.
	ok(!defined $cc || ($cc ne 'eu'),
		'"eu" from IP::Country is not returned as a country code');

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

subtest 'geo: IP::Country returns "HK" — remapped to "cn"' => sub {
	# POD/code comment: "HK is no longer a separate country in Whois"
	local %ENV = (REMOTE_ADDR => $IP{PUBLIC});
	my $l = _obj([$LANG{EN}]);
	_inject_ipcountry($l, 'HK');
	is($l->country(), 'cn', 'HK from IP::Country is remapped to cn');
	{ local $SIG{__WARN__} = sub {}; Test::Mockingbird::restore_all() }
	_block_network();
};

subtest 'geo: geoplugin returns empty JSON object — country() returns undef' => sub {
	SKIP: {
		skip 'LWP::Simple::WithCache or JSON::Parse not installed', 1
			unless $HAS_LWP && $HAS_JSON;

		local %ENV = (REMOTE_ADDR => $IP{PUBLIC});
		Test::Mockingbird::mock('LWP::Simple::WithCache', 'get', sub { '{}' });

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

		my $cc = $l->country();
		# {} has no geoplugin_countryCode key — Whois (no-op mock) is tried next.
		ok(!defined $cc, 'Empty JSON from geoplugin results in undef country');

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

subtest 'geo: geoplugin returns malformed JSON — country() survives' => sub {
	SKIP: {
		skip 'LWP::Simple::WithCache or JSON::Parse not installed', 1
			unless $HAS_LWP && $HAS_JSON;

		local %ENV = (REMOTE_ADDR => $IP{PUBLIC});
		# Malformed JSON causes JSON::Parse to throw.  The eval{} in country()
		# must absorb the error and fall through rather than crashing.
		Test::Mockingbird::mock('LWP::Simple::WithCache', 'get',
			sub { 'NOT VALID JSON {{{' });

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

		my $cc;
		lives_ok { $cc = $l->country() }
			'Malformed geoplugin JSON does not crash country()';

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