CGI-ACL
view release on metacpan or search on metacpan
- Correct MIN_PERL_VERSION to '5.014' in Makefile.PL accordingly
- Fix all_denied() early-return guard: allow_countries was incorrectly
included in the guard, causing allow_country()-only ACLs to fall through
to the country-check code. The country check then denied requests when
lingua->country() returned undef (e.g. during RIPE WHOIS rate-limiting),
contradicting the documented "allow_country alone has no effect" behaviour.
allow_countries is now intentionally absent from the guard so ACLs with
only allow_country() set return 0 (allow all) immediately.
[ Tests ]
- Add 5 subtests for deny_all_countries() in t/function.t
- Fix t/locales.t, t/country.t, t/integration.t: add CGI::Lingua result
caching (lingua_for() with local $_ to prevent $_ clobbering by WHOIS
modules inside map/grep), RIPE rate-limit detection, and SKIP blocks so
tests that depend on RIPE WHOIS resolve gracefully when the server is
rate-limiting. Reduces WHOIS round-trips per test run from O(N subtests)
to O(distinct IPs) (338 tests total)
- Fix all_denied() country check entry condition: replace
"if(deny_countries || allow_countries)" with "if(deny_countries)".
Premise: allow_countries alone always produces 0 in non-wildcard mode.
Conclusion: it is vacuous in the condition and triggers an unnecessary
lingua lookup; removing it is a strict boolean reduction. Transitive
t/dist.t
t/edge_cases.t
t/eof.t
t/eol.t
t/extended_tests.t
t/function.t
t/gv.t
t/integration.t
t/ip.t
t/kwalitee.t
t/locales.t
t/logic_reducer.t
t/manifest.t
t/metrics.t
t/mutant_killers.t
t/no404s.t
t/noop.t
t/noopentickets.t
t/noplan.t
t/pod-cm.t
t/pod-links.t
t/cgi_security.t view on Meta::CPAN
my $acl = CGI::ACL->new()->allow_ip($LOOPBACK);
my $start = time();
my $result = denied_at($acl, $LONG_ADDR);
my $elapsed = time() - $start;
is($result, 1, 'overlong REMOTE_ADDR denied');
ok($elapsed < 5, "evaluated in under 5 s (elapsed: ${elapsed}s)");
};
subtest 'ATTACK: Unicode characters in REMOTE_ADDR' => sub {
# Exploit: wide characters or multi-byte sequences in REMOTE_ADDR could
# corrupt length-based checks or confuse locale-sensitive regex engines.
my $acl = CGI::ACL->new()->allow_ip($LOOPBACK);
my $result = eval { denied_at($acl, "\x{e9}vil.host") };
ok(!$@, 'Unicode REMOTE_ADDR does not throw an exception');
is($result, 1, 'Unicode REMOTE_ADDR is denied');
};
subtest 'ATTACK: empty-string REMOTE_ADDR (defined-or vs. logical-or regression)' => sub {
# Exploit: the old code used `|| $DEFAULT_ADDR`, which substituted loopback
# for any falsy value including "". Fixed to `// $DEFAULT_ADDR`.
# An empty string must be rejected as an invalid IP, not silently treated
t/locales.t view on Meta::CPAN
#!/usr/bin/env perl
# locales.t -- country/locale-based access control tests
#
# Tests CGI::ACL with real CGI::Lingua country detection for English,
# French, German, and Mandarin-speaking regions. All IP->country mappings
# are verified against the installed GeoIP database.
use strict;
use warnings;
use Errno qw(ENOENT);
use File::Spec;
t/locales.t view on Meta::CPAN
my $acl = CGI::ACL->new()
->deny_country($config{WILDCARD})
->allow_country($config{CC_FR});
diag "French-only: allow_countries=" . join(',', sort keys %{$acl->{allow_countries}}) if $ENV{TEST_VERBOSE};
# Both French IPs must be allowed
is(denied_at($acl, $config{IP_FR}, lingua => lingua_for($config{IP_FR})), 0, 'FR (Free.fr) allowed on French-only site');
is(denied_at($acl, $config{IP_FR2}, lingua => lingua_for($config{IP_FR2})), 0, 'FR (INRIA) allowed on French-only site');
# All other locales must be denied
is(denied_at($acl, $config{IP_GB}, lingua => lingua_for($config{IP_GB})), 1, 'GB denied on French-only site');
is(denied_at($acl, $config{IP_US}, lingua => lingua_for($config{IP_US})), 1, 'US denied on French-only site');
is(denied_at($acl, $config{IP_DE}, lingua => lingua_for($config{IP_DE})), 1, 'DE denied on French-only site');
is(denied_at($acl, $config{IP_CN}, lingua => lingua_for($config{IP_CN})), 1, 'CN denied on French-only site');
};
# ── Locale scenario: German-only site ────────────────────────────────────────
# Purpose: allow only clients from Germany, deny everyone else
subtest 'German-only site: allow DE, deny others' => sub {
my $acl = CGI::ACL->new()
->deny_country($config{WILDCARD})
->allow_country($config{CC_DE});
diag "German-only: allow_countries=" . join(',', sort keys %{$acl->{allow_countries}}) if $ENV{TEST_VERBOSE};
# Both German IPs must be allowed
is(denied_at($acl, $config{IP_DE}, lingua => lingua_for($config{IP_DE})), 0, 'DE (T-Online) allowed on German-only site');
is(denied_at($acl, $config{IP_DE2}, lingua => lingua_for($config{IP_DE2})), 0, 'DE (T-Online2) allowed on German-only site');
# All other locales must be denied
is(denied_at($acl, $config{IP_GB}, lingua => lingua_for($config{IP_GB})), 1, 'GB denied on German-only site');
is(denied_at($acl, $config{IP_US}, lingua => lingua_for($config{IP_US})), 1, 'US denied on German-only site');
is(denied_at($acl, $config{IP_FR}, lingua => lingua_for($config{IP_FR})), 1, 'FR denied on German-only site');
is(denied_at($acl, $config{IP_CN}, lingua => lingua_for($config{IP_CN})), 1, 'CN denied on German-only site');
};
# ── Locale scenario: Mandarin-only site ──────────────────────────────────────
# Purpose: allow only clients from China, deny everyone else
subtest 'Mandarin-only site: allow CN, deny others' => sub {
my $acl = CGI::ACL->new()
->deny_country($config{WILDCARD})
->allow_country($config{CC_CN});
diag "Mandarin-only: allow_countries=" . join(',', sort keys %{$acl->{allow_countries}}) if $ENV{TEST_VERBOSE};
# Both Chinese IPs must be allowed
is(denied_at($acl, $config{IP_CN}, lingua => lingua_for($config{IP_CN})), 0, 'CN (Baidu) allowed on Mandarin-only site');
is(denied_at($acl, $config{IP_CN2}, lingua => lingua_for($config{IP_CN2})), 0, 'CN (114DNS) allowed on Mandarin-only site');
# All other locales must be denied
is(denied_at($acl, $config{IP_GB}, lingua => lingua_for($config{IP_GB})), 1, 'GB denied on Mandarin-only site');
is(denied_at($acl, $config{IP_US}, lingua => lingua_for($config{IP_US})), 1, 'US denied on Mandarin-only site');
is(denied_at($acl, $config{IP_FR}, lingua => lingua_for($config{IP_FR})), 1, 'FR denied on Mandarin-only site');
is(denied_at($acl, $config{IP_DE}, lingua => lingua_for($config{IP_DE})), 1, 'DE denied on Mandarin-only site');
};
# ── Locale scenario: European multilingual site ───────────────────────────────
# Purpose: allow clients from GB, FR, and DE; deny US and CN
subtest 'European multilingual site: allow GB+FR+DE, deny US+CN' => sub {
my $acl = CGI::ACL->new()
t/locales.t view on Meta::CPAN
is(denied_at($acl, $config{IP_FR}, lingua => lingua_for($config{IP_FR})), 0, 'FR allowed on EU site');
is(denied_at($acl, $config{IP_DE}, lingua => lingua_for($config{IP_DE})), 0, 'DE allowed on EU site');
# Non-European clients must be denied
is(denied_at($acl, $config{IP_US}, lingua => lingua_for($config{IP_US})), 1, 'US denied on EU site');
is(denied_at($acl, $config{IP_CN}, lingua => lingua_for($config{IP_CN})), 1, 'CN denied on EU site');
};
# ── Locale scenario: globally-available multilingual site ────────────────────
# Purpose: allow all four language regions; only deny would come from deny_country
subtest 'Multilingual site: all four locales allowed' => sub {
# Deny all by default, then explicitly permit the four target regions
my $acl = CGI::ACL->new()
->deny_country($config{WILDCARD})
->allow_country($config{CC_GB})
->allow_country($config{CC_US})
->allow_country($config{CC_FR})
->allow_country($config{CC_DE})
->allow_country($config{CC_CN});
diag "Multilingual: allow_countries=" . join(',', sort keys %{$acl->{allow_countries}}) if $ENV{TEST_VERBOSE};
t/locales.t view on Meta::CPAN
# CGI::Lingua returns lowercase; the ACL normalises codes so case must not matter
is(denied_at($acl, $config{IP_GB}, lingua => lingua_for($config{IP_GB})), 0, 'GB (uppercase in ACL) matched case-insensitively');
is(denied_at($acl, $config{IP_FR}, lingua => lingua_for($config{IP_FR})), 0, 'FR (mixed case in ACL) matched case-insensitively');
is(denied_at($acl, $config{IP_DE}, lingua => lingua_for($config{IP_DE})), 0, 'DE (uppercase in ACL) matched case-insensitively');
# Countries not in the allow list must still be denied
is(denied_at($acl, $config{IP_US}, lingua => lingua_for($config{IP_US})), 1, 'US denied (not in allow list)');
is(denied_at($acl, $config{IP_CN}, lingua => lingua_for($config{IP_CN})), 1, 'CN denied (not in allow list)');
};
# ── Locale scenario: concurrent locale-specific ACLs ─────────────────────────
# Purpose: two ACL objects for different regions must not interfere with each other
subtest 'Concurrent locale ACLs: French site and German site are independent' => sub {
# ACL A: French-only
my $acl_fr = CGI::ACL->new()
->deny_country($config{WILDCARD})
->allow_country($config{CC_FR});
# ACL B: German-only (created separately, must not share state with ACL A)
my $acl_de = CGI::ACL->new()
->deny_country($config{WILDCARD})
->allow_country($config{CC_DE});
t/locales.t view on Meta::CPAN
is(denied_at($acl_de, $config{IP_FR}, lingua => lingua_for($config{IP_FR})), 1, 'FR denied by DE ACL');
# Adding a country to one ACL must not affect the other
$acl_fr->allow_country($config{CC_US});
is(denied_at($acl_fr, $config{IP_US}, lingua => lingua_for($config{IP_US})), 0, 'US now allowed by (modified) FR ACL');
is(denied_at($acl_de, $config{IP_US}, lingua => lingua_for($config{IP_US})), 1, 'US still denied by DE ACL (unaffected)');
};
} # end SKIP block for RIPE-dependent country ACL tests
# ── System locale: error path behaviour ──────────────────────────────────────
# Purpose: verify that CGI::ACL->new() with a missing config file throws an
# exception whose message matches what Perl's own $! produces for ENOENT,
# regardless of the OS locale (LC_ALL / LANG).
#
# The correct idiom is:
# local $! = ENOENT; my $msg = "$!";
# NOT: POSIX::strerror(ENOENT)
#
# strerror() uses the C library's LC_MESSAGES locale. On systems where that
# diverges from Perl's $! locale (a common configuration on CPAN smoke boxes),
# the two strings differ and the regex fails. The bug was observed on a
# German smoker where strerror(ENOENT) returned "Datei oder Verzeichnis nicht
# gefunden" but $! returned "No such file or directory".
# Discover which locales are installed; always include C as a safe fallback.
my @system_locales = do {
# Untaint PATH before calling locale(1) so the test is safe under -T
local $ENV{PATH} = '/usr/bin:/bin';
my @all = map { chomp; $_ } qx(locale -a 2>/dev/null);
my %have = map { $_ => 1 } @all;
# Test English, French, German and Mandarin if available; C is always present
grep { $have{$_} }
qw(C en_US.UTF-8 de_DE.UTF-8 fr_FR.UTF-8 zh_CN.UTF-8);
};
# A path that is guaranteed not to exist during the test run
my $temp_dir = tempdir(CLEANUP => 1);
my $bad_config = File::Spec->catfile($temp_dir, 'nonexistent.conf');
subtest 'System locale: new() throws on missing config_file under all locales' => sub {
plan tests => scalar @system_locales;
for my $locale (@system_locales) {
local $ENV{LC_ALL} = $locale;
local $ENV{LANG} = $locale;
# Derive the expected error string from Perl's own $! — the same
# source that Object::Configure uses when it croaks. Never use
# POSIX::strerror() here; it uses the C library locale and can
# produce a different string on mixed-locale systems.
local $! = ENOENT;
my $enoent = "$!";
diag "LC_ALL=$locale ENOENT via \$! = '$enoent'" if $ENV{TEST_VERBOSE};
throws_ok {
CGI::ACL->new(config_file => $bad_config)
} qr/\Q$enoent\E/,
"LC_ALL=$locale: exception contains locale-aware ENOENT string";
}
};
# Purpose: confirm that the $! approach and strerror() agree on this system.
# If they diverge, the warning flags that POSIX::strerror() is unsafe to use
# in tests on this platform.
subtest 'System locale: $! and POSIX::strerror agree for ENOENT' => sub {
require POSIX;
for my $locale (@system_locales) {
local $ENV{LC_ALL} = $locale;
local $ENV{LANG} = $locale;
local $! = ENOENT;
my $perl_msg = "$!";
my $c_msg = POSIX::strerror(ENOENT);
diag "LC_ALL=$locale \$!='$perl_msg' strerror='$c_msg'" if $ENV{TEST_VERBOSE};
# On most systems these agree; a mismatch is a platform warning,
# not a hard failure — the point is to document where they diverge.
TODO: {
local $TODO = ($perl_msg ne $c_msg)
? "locale $locale: \$! and strerror() diverge on this platform"
: undef;
is($perl_msg, $c_msg, "LC_ALL=$locale: \$! eq POSIX::strerror(ENOENT)");
}
}
};
done_testing();
( run in 0.784 second using v1.01-cache-2.11-cpan-a5162978ef8 )