package Net::CIDR::Lookup::Test;
use strict;
use warnings;
use parent 'My::Test::Class';
use Carp;
use Test::More;
use Test::Exception;
use Socket qw/ inet_aton /;
#-------------------------------------------------------------------------------
sub check_methods : Test(startup => 8) {
my $t = shift->class->new;
can_ok($t, 'add');
can_ok($t, 'add_num');
can_ok($t, 'add_range');
can_ok($t, 'lookup');
can_ok($t, 'lookup_num');
can_ok($t, 'clear');
can_ok($t, 'to_hash');
can_ok($t, 'walk');
}
sub before : Test(setup) {
my $self = shift;
$self->{tree} = $self->class->new;
}
#-------------------------------------------------------------------------------
sub add : Tests(3) {
my $t = shift->{tree};
$t->add('192.168.0.129/25', 42);
$t->add('1.2.0.0/15', 23);
is($t->lookup('192.168.0.161'), 42, 'Block 192.168.0.129/25 lookup OK');
is($t->lookup('1.3.123.234'), 23, 'Block 1.2.0.0/15 lookup OK');
is($t->lookup('2.3.4.5'), undef, 'No result outside blocks');
}
sub lookup_num : Tests(2) {
my $t = shift->{tree};
$t->add('192.168.0.129/25', 42);
$t->add('1.2.0.0/15', 23);
is($t->lookup_num(_dq2int('192.168.0.130')), 42, 'lookup_num() found in range');
is($t->lookup_num(_dq2int('192.188.0.1')), undef, 'lookup_num() not found outside');
}
sub add_range : Tests(4) {
my $t = shift->{tree};
$t->add_range('192.168.0.130-192.170.0.1', 42);
$t->add_range('1.3.123.234 - 1.3.123.240', 23);
is($t->lookup('192.169.0.22'), 42, 'Range 192.168.0.130 - 192.170.0.1');
is($t->lookup('1.3.123.235'), 23, 'Range 1.3.123.234 - 1.3.123.240');
is($t->lookup('2.3.4.5'), undef, 'No result outside blocks');
my $h = $t->to_hash;
is(scalar keys %$h, 19, 'Range expansion: number of keys');
}
sub collision : Test(1) {
my $t = shift->{tree};
$t->add('192.168.0.129/25', 42);
dies_ok(sub { $t->add('192.168.0.160/31', 23) }, 'Collision: add() failed as expected');
}
sub benign_collision : Test(1) {
my $t = shift->{tree};
$t->add('192.168.0.129/25', 42);
lives_ok(sub { $t->add('192.168.0.160/31', 42) }, 'Benign collision: add() succeeded');
}
sub merger : Tests(2) {
my $t = shift->{tree};
$t->add('192.168.0.130/25', 42);
$t->add('192.168.0.0/25', 42);
my $h = $t->to_hash;
is(scalar keys %$h, 1, 'Merged block: number of keys');
my ($k,$v) = each %$h;
is($k, '192.168.0.0/24', 'Merged block: correct merged net block');
}
sub recursive_merger : Tests(2) {
my $t = shift->{tree};
$t->add('0.1.1.0/24', 42);
$t->add('0.1.0.128/25', 42);
$t->add('0.1.0.0/25', 42);
my $h = $t->to_hash;
is(scalar keys %$h, 1, 'Recursively merged block: number of keys');
my ($k,$v) = each %$h;
is($k, '0.1.0.0/23', 'Recursively merged block: correct merged net block');
}
sub nonmerger : Tests(1) {
my $t = shift->{tree};
$t->add('192.168.0.130/25', 42);
$t->add('192.168.0.0/25', 23);
my $h = $t->to_hash;
is(scalar keys %$h, 2, 'Unmerged adjacent blocks: correct number of keys');
}
sub equalrange : Tests(2) {
my $t = shift->{tree};
$t->add('192.168.0.130/25', 1);
$t->add('192.168.0.130/25', 1);
my $h = $t->to_hash;
is(0+keys %$h, 1, 'Got single block from two equal inserts');
is($h->{'192.168.0.128/25'}, 1, 'Got correct block');
}
sub subrange1 : Tests(2) {
my $t = shift->{tree};
$t->add('192.168.0.1/24', 1);
$t->add('192.168.0.1/25', 1);
my $h = $t->to_hash;
is(0+keys %$h, 1, 'Immediate subrange: resulted in single block');
is($h->{'192.168.0.0/24'}, 1, 'Immediate subrange: got correct block');
}
sub subrange2 : Tests(2) {
my $t = shift->{tree};
$t->add('192.168.0.1/24', 1);
$t->add('192.168.0.1/28', 1);
my $h = $t->to_hash;
is(0+keys %$h, 1, 'Small subrange: resulted in single block');
is($h->{'192.168.0.0/24'}, 1, 'Small subrange: got correct block');
}
sub superrange1 : Tests(2) {
my $t = shift->{tree};
$t->add('192.168.0.128/25', 1);
$t->add('192.168.0.0/24', 1);
my $h = $t->to_hash;
is(0+keys %$h, 1, 'Immediate superrange: resulted in single block');
is($h->{'192.168.0.0/24'}, 1, 'Immediate superrange: got correct block');
}
sub superrange2 : Tests(2) {
my $t = shift->{tree};
$t->add('192.168.160.128/25', 1);
$t->add('192.168.160.0/20', 1);
my $h = $t->to_hash;
is(0+keys %$h, 1, 'Big superrange: resulted in single block');
is($h->{'192.168.160.0/20'}, 1, 'Big superrange: got correct block');
}
sub to_hash : Tests(3) {
my $t = shift->{tree};
$t->add_range('31.201.1.36-31.201.1.39', 1); # 31.201.1.36/30
$t->add_range('32.105.59.0-32.105.59.255', 1); # 32.105.59.0/24
my $h = $t->to_hash;
ok((defined $h->{'31.201.1.36/30'} and defined $h->{'32.105.59.0/24'}), 'to_hash(): correct keys');
ok((1 == $h->{'31.201.1.36/30'} and 1 == $h->{'32.105.59.0/24'}), 'to_hash(): correct values');
ok(2 == keys %$h, 'to_hash(): no spurious keys');
}
sub clear : Tests(1) {
my $t = shift->{tree};
$t->add('192.168.0.129/25', 42);
$t->clear;
is(scalar keys %{$t->to_hash}, 0, 'Reinitialized tree');
}
#-------------------------------------------------------------------------------
# Duplicated here so we don't depend on the check in Lookup.pm
sub _dq2int { ## no critic (Subroutines::RequireArgUnpacking)
my @oct = split /\./, $_[0];
4 == @oct or croak "address must be in dotted-quad form, is `$_[0]'";
my $ip = 0;
foreach(@oct) {
$_ <= 255 and $_ >= 0
or croak "invalid component `$_' in address `$_[0]'";
$ip = $ip<<8 | $_;
}
return $ip;
}
1;