view release on metacpan or  search on metacpan

t/function.t  view on Meta::CPAN

#!/usr/bin/env perl
# function.t -- white-box function-level tests for CGI::ACL

use strict;
use warnings;

use Carp;	# required: prevents Test::Carp glob aliasing from clearing Carp::carp
use Test::Most;
use Test::Carp;
use Test::Memory::Cycle;
use Test::Mockingbird;
use Test::Returns;
use Readonly;
use Scalar::Util qw(refaddr);
use Socket qw(AF_INET);

# Load the module under test
BEGIN { use_ok('CGI::ACL') }

# ── Configuration ────────────────────────────────────────────────────────────

# All test constants live here; no magic strings or numbers elsewhere
Readonly my %config => (
	LOCAL_IP              => '127.0.0.1',
	RFC5737_IP            => '203.0.113.5',     # TEST-NET-3 per RFC 5737
	RFC5737_IP2           => '198.51.100.1',    # TEST-NET-2 per RFC 5737
	RFC5737_CIDR          => '192.0.2.0/24',    # TEST-NET-1 per RFC 5737
	CIDR_INSIDE           => '192.0.2.100',     # falls inside RFC5737_CIDR
	CIDR_OUTSIDE          => '10.0.0.1',        # outside all test CIDRs
	IPv6_ADDR             => '2001:db8::1',     # documentation IPv6 per RFC 3849
	IPv6_ADDR2            => '2001:db8::2',     # second documentation IPv6
	IPv6_INVALID          => 'not::a::valid::ipv6::too::many',  # too many groups
	INVALID_IP            => 'not-an-ip',       # clearly malformed address
	INVALID_IP2           => '999.999.999.999', # out-of-range dotted quad
	COUNTRY_GB            => 'gb',
	COUNTRY_US            => 'us',
	COUNTRY_BR            => 'br',
	COUNTRY_GB_UPPER      => 'GB',
	COUNTRY_US_UPPER      => 'US',
	WILDCARD              => '*',

	# Cloud-provider hostname samples for _is_cloud_host() tests
	AWS_HOST              => 'ec2-1-2-3-4.compute-1.amazonaws.com',
	GCP_HOST              => '203-0-113-5.bc.googleusercontent.com',
	AZURE_HOST            => 'myvm.cloudapp.net',
	AZURE_HOST2           => 'myvm.azure.com',
	DO_HOST               => 'myserver.digitalocean.something',
	LINODE_HOST           => 'li-1234-5.members.linode.com',
	HETZNER_HOST          => 'srv1.hetzner.de',
	HETZNER_LEGACY_HOST   => 'srv1.your-server.de',
	OVH_HOST              => 'ns1234.ovh.net',
	OVH_EU_HOST           => 'ip-1-2-3-4.eu',
	NONCLOUD_HOST         => 'mail.example.com',

	# Expected carp/crog message fragments
	DENY_ALL_WARN         => 'Usage: all_denied($lingua)',
	DENY_IP_WARN          => 'Usage: allow_ip($ip_address)',
	DENY_COUNTRY_WARN     => 'Usage: deny_country($country)',
	ALLOW_COUNTRY_WARN    => 'Usage: allow_country($country)',
	PLAIN_FN_WARN         => 'CGI::ACL: use ->new() not ::new() to instantiate',
);

# ── Mock Lingua helpers ───────────────────────────────────────────────────────

# Minimal lingua stub that returns a fixed country code
{
	package Test::FakeLingua;
	sub new      { my ($class, $country) = @_; bless { country => $country }, $class }
	sub country  { $_[0]->{country} }
}

# Lingua stub whose country() always throws — tests the eval guard in all_denied()
{
	package Test::DyingLingua;
	sub new     { bless {}, shift }
	sub country { die "country() intentionally dies for testing\n" }
}

# ── Helper ───────────────────────────────────────────────────────────────────

# Run all_denied() with a controlled REMOTE_ADDR
sub denied_with_addr {
	my ($acl, $addr, @rest) = @_;
	local $ENV{REMOTE_ADDR} = $addr;
	return $acl->all_denied(@rest);
}

# ─────────────────────────────────────────────────────────────────────────────
# Subtest: new()
# Purpose: verify constructor handles class method, function, and clone paths
# ─────────────────────────────────────────────────────────────────────────────
subtest 'new() - class method returns blessed CGI::ACL object' => sub {
	my $acl = CGI::ACL->new();
	diag "new() returned: $acl" if $ENV{TEST_VERBOSE};

	# Must be a defined, blessed reference
	ok(defined $acl, 'new() returns defined value');
	isa_ok($acl, 'CGI::ACL', 'object has correct class');

	# Confirm schema compliance via Test::Returns
	returns_ok($acl, { type => 'OBJECT' }, 'return schema ok');

	# Fresh object has no restrictions
	is($acl->{allowed_ips},     undef, 'allowed_ips is undef initially');
	is($acl->{deny_countries},  undef, 'deny_countries is undef initially');
	is($acl->{allow_countries}, undef, 'allow_countries is undef initially');
	is($acl->{deny_cloud},      undef, 'deny_cloud is undef initially');
};

# Purpose: calling new() with pre-seeded hash populates the fields
subtest 'new() - with initial arguments' => sub {
	my $acl = CGI::ACL->new(deny_cloud => 1);
	diag "new(deny_cloud=>1) deny_cloud=$acl->{deny_cloud}" if $ENV{TEST_VERBOSE};

	isa_ok($acl, 'CGI::ACL', 'new with args returns object');