view release on metacpan or  search on metacpan

t/data-flow.t  view on Meta::CPAN

	# The key format is ip/lang/supported; simulate a stale Storable entry.
	my $key = join('/', $IP{PUBLIC}, $LANG{EN}, $LANG{EN});
	$cache->set($key, "\x05\x0b\x13garbage\x00", '1 hour');    # binary garbage, not JSON

	# Construction must not die despite the bad cache blob.
	my $l;
	lives_ok { $l = _obj([$LANG{EN}], cache => $cache) }
		'non-JSON cache blob does not crash new()';

	ok(blessed($l) && $l->isa('CGI::Lingua'),
		'fresh CGI::Lingua object returned despite poisoned cache');
};

subtest 'new(): non-HASH JSON blob is discarded (array instead of object)' => sub {
	# A valid JSON array is not a hashref — rc check `ref($rc) eq 'HASH'` rejects it.
	local %ENV = (REMOTE_ADDR => $IP{PUBLIC}, HTTP_ACCEPT_LANGUAGE => $LANG{EN});
	my $cache = _fresh_cache();
	my $key = join('/', $IP{PUBLIC}, $LANG{EN}, $LANG{EN});
	$cache->set($key, JSON::PP::encode_json([1, 2, 3]), '1 hour');

	my $l;
	lives_ok { $l = _obj([$LANG{EN}], cache => $cache) }
		'JSON array blob does not crash new()';
	ok(blessed($l), 'fresh object returned for JSON-array blob');
};

subtest 'new(): valid JSON hash blob is thawed and fields re-injected' => sub {
	# D→U: the rc hashref is blessed and its transient fields re-injected from params.
	local %ENV = (REMOTE_ADDR => $IP{PUBLIC}, HTTP_ACCEPT_LANGUAGE => $LANG{EN});
	my $cache = _fresh_cache();

	# Build a valid state blob (exactly what DESTROY writes).
	my %state = (
		_slanguage             => 'English',
		_slanguage_code_alpha2 => 'en',
		_country               => 'us',
		_rlanguage             => 'English',
		_dont_use_ip           => 0,
		_have_ipcountry        => -1,
		_have_geoip            => -1,
		_have_geoipfree        => -1,
	);
	my $key = join('/', $IP{PUBLIC}, $LANG{EN}, $LANG{EN});
	$cache->set($key, JSON::PP::encode_json(\%state), '1 hour');

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

	is($l->language(), 'English',   'thawed _slanguage used by language()');
	is($l->{_country}, 'us',        'thawed _country re-inflated');
	# logger is re-injected by new() from $params (Object::Configure provides one).
	# Verify heavy non-serialised objects (_ipcountry, _geoip) are NOT present.
	ok(!defined($l->{_ipcountry}),  '_ipcountry not in thawed object (not serialised)');
	ok(!defined($l->{_geoip}),      '_geoip not in thawed object (not serialised)');

	diag('Thawed object keys: ' . join(', ', sort keys %{$l}))
		if $ENV{TEST_VERBOSE};
};

# ═══════════════════════════════════════════════════════════════════════════════
# SECTION 5: $_locale_object_db_ok package sentinel — transition and persistence
# ═══════════════════════════════════════════════════════════════════════════════
#
# The sentinel starts at undef, moves to 1 (present) or 0 (absent).
# Once set to 0 it must stay 0 (no repeated failed Locale::Object probes).
# Tested indirectly via _code2country and _resolve_sublanguage_match.

subtest '$_locale_object_db_ok: once set to 0, _code2country skips Locale::Object' => sub {
	# Force the sentinel to 0 by injecting it at package level.
	# CGI::Lingua exposes no public accessor so we use the symbol table.
	{
		no strict 'refs';
		${'CGI::Lingua::_locale_object_db_ok'} = 0;
	}

	local %ENV = (HTTP_ACCEPT_LANGUAGE => $LANG{EN_GB});
	my $l = _obj([$LANG{EN_GB}]);

	# With sentinel = 0, _code2country returns undef; _code2countryname should
	# fall back to _country_short_name (via %COUNTRY_SHORT_NAMES).
	my $sub = $l->sublanguage();

	# Reset sentinel to undef so other tests see a clean slate.
	{
		no strict 'refs';
		${'CGI::Lingua::_locale_object_db_ok'} = undef;
	}

	# The short-name table covers 'gb' → 'United Kingdom'.
	is($sub, 'United Kingdom',
		'_country_short_name fallback works when sentinel is 0 (no Locale::Object call)');
};

# ═══════════════════════════════════════════════════════════════════════════════
# SECTION 6: $_have_dvip sentinel — symbol-table alias installation
# ═══════════════════════════════════════════════════════════════════════════════
#
# When $_have_dvip transitions to 0, four pure-Perl aliases are installed in
# the CGI::Lingua symbol table.  Verify they are callable and correct.

subtest '$_have_dvip = 0: pure-Perl IP functions installed and callable' => sub {
	# Force the sentinel to the "broken" state; country() will install aliases.
	{
		no strict 'refs';
		${'CGI::Lingua::_have_dvip'} = undef;    # reset to probe state
	}

	# Temporarily make Data::Validate::IP appear to fail.
	{
		no warnings 'redefine';
		no strict 'refs';
		# Patch _have_dvip to 0 and install the fallbacks manually (mirrors what
		# country() does internally when the eval fails).
		${'CGI::Lingua::_have_dvip'} = 0;
		*CGI::Lingua::is_ipv4        = \&CGI::Lingua::_is_ipv4;
		*CGI::Lingua::is_ipv6        = \&CGI::Lingua::_is_ipv6;
		*CGI::Lingua::is_private_ip  = \&CGI::Lingua::_is_private_ip;
		*CGI::Lingua::is_loopback_ip = \&CGI::Lingua::_is_loopback_ip;
	}

	# Now verify the installed aliases behave correctly.
	ok( CGI::Lingua::is_ipv4('8.8.8.8'),         'is_ipv4: valid IPv4');
	ok(!CGI::Lingua::is_ipv4('999.0.0.0'),        'is_ipv4: octet > 255 rejected');
	ok(!CGI::Lingua::is_ipv4('::1'),              'is_ipv4: IPv6 rejected');
	ok( CGI::Lingua::is_private_ip('10.0.0.1'),   'is_private_ip: 10/8');
	ok( CGI::Lingua::is_private_ip('172.16.0.1'), 'is_private_ip: 172.16/12');
	ok( CGI::Lingua::is_private_ip('192.168.1.1'),'is_private_ip: 192.168/16');
	ok(!CGI::Lingua::is_private_ip('8.8.8.8'),    'is_private_ip: public IP false');
	ok( CGI::Lingua::is_loopback_ip('127.0.0.1'), 'is_loopback_ip: 127.0.0.1');
	ok( CGI::Lingua::is_loopback_ip('::1'),       'is_loopback_ip: ::1');
	ok(!CGI::Lingua::is_loopback_ip('8.8.8.8'),   'is_loopback_ip: public IP false');

	# Restore the sentinel to undef so subsequent tests probe normally.
	{
		no strict 'refs';
		${'CGI::Lingua::_have_dvip'} = undef;
	}
};

# ═══════════════════════════════════════════════════════════════════════════════
# SECTION 7: Geo module sentinels — GEO_UNKNOWN → GEO_ABSENT transition
# ═══════════════════════════════════════════════════════════════════════════════
#
# _have_ipcountry / _have_geoip / _have_geoipfree start at GEO_UNKNOWN (-1).
# After the first country() call the sentinel must reflect the probe outcome.
# The transition must happen exactly once — not on every call.

subtest 'geo sentinels: GEO_UNKNOWN (-1) transitions on first country() call' => sub {
	# Test::Without::Module qw(IP::Country) blocks require IP::Country but NOT
	# require IP::Country::Fast (the concrete class country() requires).  So
	# _have_ipcountry may transition to either GEO_ABSENT (0) or GEO_PRESENT (1)
	# depending on whether IP::Country::Fast is installed.  What we assert is
	# that it is NO LONGER GEO_UNKNOWN (-1) after the first call.
	local %ENV = (REMOTE_ADDR => $IP{PUBLIC});
	my $l = _obj([$LANG{EN}]);

	is($l->{_have_ipcountry},  -1, '_have_ipcountry starts at GEO_UNKNOWN');
	is($l->{_have_geoip},      -1, '_have_geoip starts at GEO_UNKNOWN');
	is($l->{_have_geoipfree},  -1, '_have_geoipfree starts at GEO_UNKNOWN');

	$l->country();    # triggers probe

	isnt($l->{_have_ipcountry}, -1,
		'_have_ipcountry no longer GEO_UNKNOWN after first call');

	diag(sprintf '_have_ipcountry=%d _have_geoip=%d _have_geoipfree=%d',
		$l->{_have_ipcountry}, $l->{_have_geoip}, $l->{_have_geoipfree})
		if $ENV{TEST_VERBOSE};
};

subtest 'geo sentinels: second country() call does not re-probe (D→U, no re-D)' => sub {
	# DD anomaly check: the sentinel must not be re-assigned on every call.
	# Verified by calling country() twice and checking sentinel stability.
	local %ENV = (REMOTE_ADDR => $IP{PUBLIC});
	my $l = _obj([$LANG{EN}]);
	$l->country();    # first call: probes and sets sentinels

	my $sentinel_after_first = $l->{_have_ipcountry};

	# Intercept any calls that would re-probe — if the sentinel is respected,
	# IP::Country::Fast should never be required again.
	$l->country();    # second call: must use cached sentinel

	is($l->{_have_ipcountry}, $sentinel_after_first,
		'_have_ipcountry unchanged on second call (no re-probe)');
};

# ═══════════════════════════════════════════════════════════════════════════════
# SECTION 8: $_ global non-pollution
# ═══════════════════════════════════════════════════════════════════════════════
#
# locale() uses an implicit $_ in its foreach loop.  Any method that calls
# split and iterates must not leave $_ in a modified state visible to the caller.

subtest '$_: not polluted by language() call' => sub {
	local %ENV = (HTTP_ACCEPT_LANGUAGE => 'en,fr;q=0.9');
	my $l = _obj([$LANG{EN}]);

	local $_ = 'sentinel_value';
	$l->language();
	is($_, 'sentinel_value', '$_ unchanged after language()');
};

subtest '$_: not polluted by sublanguage() call' => sub {
	local %ENV = (HTTP_ACCEPT_LANGUAGE => $LANG{EN_GB});
	my $l = _obj([$LANG{EN_GB}]);

	local $_ = 'sentinel_value';
	$l->sublanguage();
	is($_, 'sentinel_value', '$_ unchanged after sublanguage()');
};

subtest '$_: not polluted by locale() foreach loop' => sub {
	local %ENV = (HTTP_USER_AGENT => 'Mozilla/5.0 (en-GB; rv:109.0) Gecko/20100101');
	delete local $ENV{REMOTE_ADDR};
	my $l = _obj([$LANG{EN}]);

	local $_ = 'sentinel_value';
	$l->locale();
	is($_, 'sentinel_value', '$_ unchanged after locale() foreach loop');
};

subtest '$_: not polluted by country() call' => sub {
	local %ENV = (GEOIP_COUNTRY_CODE => $CC_GB);
	my $l = _obj([$LANG{EN}]);

	local $_ = 'sentinel_value';
	$l->country();
	is($_, 'sentinel_value', '$_ unchanged after country()');
};

# ═══════════════════════════════════════════════════════════════════════════════
# SECTION 9: $@ non-leakage from eval blocks
# ═══════════════════════════════════════════════════════════════════════════════
#
# Multiple eval blocks in country(), new(), _code2country(), time_zone().
# Each must leave $@ in a defined/clean state visible to the caller — or at
# least not propagate an error that wasn't theirs.

subtest '$@: country() does not leak $@ to caller' => sub {
	local %ENV = (REMOTE_ADDR => $IP{PUBLIC});
	my $l = _obj([$LANG{EN}]);

	# Prime $@ with a pre-existing error to detect leakage.
	eval { die 'pre-existing-error' };
	my $before = $@;

	# A fresh call to country() must not change $@ as seen outside.
	# (The eval blocks inside country() are required to reset $@.)
	$l->country();

	# $@ after country() can legitimately be '' (eval block ran to completion)
	# but must not retain the caller's pre-existing value.
	# The specific invariant: $@ is not 'pre-existing-error'.
	unlike($@, qr/pre-existing-error/, '$@ after country() does not contain caller error');
};

subtest '$@: new() with valid JSON cache blob leaves $@ clean' => sub {
	local %ENV = (REMOTE_ADDR => $IP{PUBLIC}, HTTP_ACCEPT_LANGUAGE => $LANG{EN});
	my $cache = _fresh_cache();
	my %state = (
		_slanguage             => 'English',
		_slanguage_code_alpha2 => 'en',
		_country               => 'us',
		_rlanguage             => 'English',
		_dont_use_ip           => 0,
		_have_ipcountry        => -1,
		_have_geoip            => -1,
		_have_geoipfree        => -1,
	);
	my $key = join('/', $IP{PUBLIC}, $LANG{EN}, $LANG{EN});
	$cache->set($key, JSON::PP::encode_json(\%state), '1 hour');

	eval { die 'pre-existing' };
	_obj([$LANG{EN}], cache => $cache);

	unlike($@, qr/pre-existing/, '$@ clean after new() with valid cache blob');
};

subtest '$@: new() with invalid cache blob leaves $@ clean' => sub {