view release on metacpan or  search on metacpan

t/edge_cases.t  view on Meta::CPAN

	);
	is($ret, $acl, 'allow_ip(glob) returns $self for chaining safety');
	ok(!$acl->{allowed_ips} || !%{$acl->{allowed_ips}},
		'typeglob is not stored in allowed_ips');
};

subtest 'allow_ip(): hashref {ip => $addr} is a documented positive path' => sub {
	# POD API SPECIFICATION documents three argument forms; hashref is one of them.
	# Verify the hashref form routes through _get_param correctly.
	my $acl = CGI::ACL->new()->allow_ip({ip => $config{VALID_IP}});

	is(denied_at($acl, $config{VALID_IP}),  0, 'hashref form allow_ip: IP is permitted');
	is(denied_at($acl, $config{VALID_IP2}), 1, 'hashref form allow_ip: other IP still denied');
};

subtest 'allow_ip(): valid IP with impossible CIDR prefix — no carp, eval guard, denied' => sub {
	# '192.0.2.1' is a valid IPv4 base address so format validation passes (no carp).
	# '/33' is an impossible IPv4 prefix; Net::CIDR::cidradd dies.  The eval guard
	# in all_denied() catches the die, the CIDR list ends up empty, and every IP is
	# denied — no crash, fail-closed behaviour.
	my $acl = CGI::ACL->new();

	# No carp should be emitted (base IP is valid; only the prefix is bad)
	my $ret;
	warning_is { $ret = $acl->allow_ip($INVALID_CIDR_PFX) } undef,
		'allow_ip(valid-IP/bad-prefix) emits no warning';
	is($ret, $acl, 'returns $self on bad-prefix entry');

	# The stored entry has a valid-looking key but cidradd will fail at lookup time
	ok(defined($acl->{allowed_ips}),    'allowed_ips is defined (guard sees IP restriction)');
	ok($acl->{allowed_ips}{$INVALID_CIDR_PFX}, 'bad-prefix entry is stored under its original key');

	# Fail-closed: no IP should match, even the base address
	my $result = eval { denied_at($acl, '192.0.2.1') };
	ok(!$@,        'all_denied() does not throw on bad-prefix CIDR entry');
	is($result, 1, 'fail-closed: base IP denied (CIDR range lookup failed)');
	diag "all_denied with bad CIDR prefix: $result" if $ENV{TEST_VERBOSE};
};

subtest 'allow_ip(): IPv6 CIDR block allows addresses inside the range' => sub {
	# Net::CIDR supports IPv6; verify that a /32 prefix works end-to-end.
	my $acl = CGI::ACL->new()->allow_ip($IPv6_CIDR);

	is(denied_at($acl, $IPv6_IN_CIDR),     0, 'IPv6 address inside CIDR is allowed');
	is(denied_at($acl, $IPv6_NOT_IN_CIDR), 1, 'IPv6 address outside CIDR is denied');
	is(denied_at($acl, $config{VALID_IP}), 1, 'IPv4 address denied when only IPv6 CIDR is set');
};

subtest "allow_ip(): ${\$STRESS_IP_COUNT}-entry allow-list stress test — no crash" => sub {
	# Build an ACL with many individual CIDR /32 entries and verify the CIDR
	# rebuild machinery handles large lists without blowing the stack or OOM.
	my $acl = CGI::ACL->new();

	for my $i (1 .. $STRESS_IP_COUNT) {
		$acl->allow_ip("10.0.0.$i");    # RFC 1918, safe to use in tests
	}

	is(scalar keys %{$acl->{allowed_ips}}, $STRESS_IP_COUNT,
		"$STRESS_IP_COUNT entries stored");

	# Spot-check a few endpoints
	is(denied_at($acl, '10.0.0.1'),   0, 'first entry allowed after large list build');
	is(denied_at($acl, "10.0.0.$STRESS_IP_COUNT"), 0, 'last entry allowed');
	is(denied_at($acl, '10.0.0.' . ($STRESS_IP_COUNT + 1)), 1, 'entry beyond range denied');
	diag "stress list: $STRESS_IP_COUNT entries, CIDR cache holds" if $ENV{TEST_VERBOSE};
};

# ─────────────────────────────────────────────────────────────────────────────
# all_denied(): HOSTILE LINGUA OBJECTS
# ─────────────────────────────────────────────────────────────────────────────
subtest 'all_denied(): lingua->country() that dies is caught, treated as unknown → deny' => sub {
	# The country() call is wrapped in eval per the 0.08 fix.  A dying lingua
	# must not propagate the exception to the CGI caller.
	my $acl = CGI::ACL->new()->deny_country($config{CC_GB});

	my $result = eval { denied_at($acl, $config{VALID_IP}, lingua => DyingLingua->new()) };
	ok(!$@,        'dying lingua->country() does not propagate an unhandled exception');
	is($result, 1, 'dying lingua->country() is treated as unknown country → deny');
	diag "dying lingua result: $result" if $ENV{TEST_VERBOSE};
};

subtest 'all_denied(): lingua->country() returning 64 KiB string does not crash' => sub {
	# An unexpectedly large country() return must not blow the stack or trigger
	# a fatal regex error.  The 64 KiB value is not a valid country code so it
	# must not match any deny-list entry; the result must be a safe 0 or 1.
	my $acl_deny_gb = CGI::ACL->new()->deny_country($config{CC_GB});
	my $acl_wildcard = CGI::ACL->new()->deny_country($config{WILDCARD});

	my $result_deny = eval { denied_at($acl_deny_gb, $config{VALID_IP}, lingua => HugeLingua->new()) };
	my $result_wild = eval { denied_at($acl_wildcard, $config{VALID_IP}, lingua => HugeLingua->new()) };

	ok(!$@, 'huge lingua->country() return does not throw');
	ok(defined $result_deny && $result_deny =~ /^[01]$/, 'result is 0 or 1 for specific deny');
	is($result_wild, 1, 'huge country code: wildcard-deny treats unknown/unmatched as deny');
	diag "HugeLingua results: deny_gb=$result_deny wildcard=$result_wild" if $ENV{TEST_VERBOSE};
};

subtest 'all_denied(): typeglob passed as lingua argument — carps, returns 1 (deny)' => sub {
	# Typeglobs are not blessed objects; blessed() returns undef for them.
	# The lingua type check must fire, carp once, and return 1.
	my $acl = CGI::ACL->new()->deny_country($config{CC_GB});

	local $ENV{REMOTE_ADDR} = $config{VALID_IP};
	my $result = eval { $acl->all_denied(lingua => *STDOUT) };

	ok(!$@,        'typeglob as lingua does not throw');
	is($result, 1, 'typeglob as lingua → deny (not a blessed object)');
	diag "typeglob lingua result: $result" if $ENV{TEST_VERBOSE};
};

# ─────────────────────────────────────────────────────────────────────────────
# deny_cloud: CLOUD CACHE TTL EXPIRY AND PRIVATE-IP BYPASS
# ─────────────────────────────────────────────────────────────────────────────
subtest 'deny_cloud: expired cache entry forces a fresh DNS lookup' => sub {
	# The cache stores {result, expires}; once expires < time() the entry is stale
	# and must NOT be used.  A fresh DNS query must be triggered instead.
	my $dns_calls = 0;
	my $guard = mock_scoped 'CGI::ACL::_verified_rdns' => sub {
		$dns_calls++;
		return undef;    # non-cloud for this test
	};