File Coverage

blib/lib/IP/Authority.pm

Criterion	Covered	Total	%
statement	35	40	87.5
branch	11	16	68.7
condition	2	6	33.3
subroutine	7	8	87.5
pod	3	4	75.0
total	58	74	78.3

package IP::Authority;
use strict;
use warnings;
use Socket qw ( inet_aton );

use vars qw ( $VERSION );
$VERSION = '1305.001'; # MAY 2013, version 0.01

my $singleton = undef;
my $ip_db;
my $null = substr(pack('N',0),0,1);
my $nullnullnull = $null . $null . $null;
my %auth;
my $ip_match = qr/^(\d|[01]?\d\d|2[0-4]\d|25[0-5])\.(\d|[01]?\d\d|2[0-4]\d|25[0-5])\.(\d|[01]?\d\d|2[0-4]\d|25[0-5])\.(\d|[01]?\d\d|2[0-4]\d|25[0-5])$/o;

my $bit0;
my $bit1;
my @mask;
my @dtoc;
{
    $bit0 = substr(pack('N',2 ** 31),0,1);
    $bit1 = substr(pack('N',2 ** 30),0,1);

    for (my $i = 0; $i <= 31; $i++){
	$mask[$i] = pack('N',2 ** (31 - $i));
    }

    for (my $i = 0; $i <= 255; $i++){
	$dtoc[$i] = substr(pack('N',$i),3,1);
    }
    (my $module_dir = __FILE__) =~ s/\.pm$//;

    local $/;   # set it so <> reads all the file at once

    open (AUTH, "< $module_dir/auth.gif")
	or die ("couldn't read authority database: $!");
    binmode AUTH;
    my $auth_ultra = ;  # read in the file
    close AUTH;
    my $auth_num = (length $auth_ultra) / 3;
    for (my $i = 0; $i < $auth_num; $i++){
	my $auth = substr($auth_ultra,3 * $i + 1,2);
	$auth = undef if ($auth eq '--');
	$auth{substr($auth_ultra,3 * $i,1)} = $auth;
    }

    open (IP, "< $module_dir/ipauth.gif")
	or die ("couldn't read IP database: $!");
    binmode IP;
    $ip_db = ;
    close IP;
}

sub new ()
{
    my $caller = shift;
    unless (defined $singleton){
        my $class = ref($caller) || $caller;
	$singleton = bless {}, $class;
    }
    return $singleton;
}

sub inet_atoauth
{
    my $inet_a = $_[1];
    if ($inet_a =~ $ip_match){
	return inet_ntoauth($dtoc[$1].$dtoc[$2].$dtoc[$3].$dtoc[$4]);
    } else {
	if (defined (my $n = inet_aton($inet_a))){
	    return inet_ntoauth($n);
	} else {
	    return undef;
	}
    }
}

sub db_time
{
    return unpack("N",substr($ip_db,0,4));
}

sub inet_ntoauth
{
    my $inet_n = $_[1] || $_[0];

    my $pos = 4;
    my $byte_zero = substr($ip_db,$pos,1);
    # loop through bits of IP address
    for (my $i = 0; $i <= 31; $i++){

	if (($inet_n & $mask[$i]) eq $mask[$i]){
	    # bit[$i] is set [binary one]
	    # - jump to next node
	    # (start of child[1] node)
	    if (($byte_zero & $bit1) eq $bit1){
		$pos = $pos + 1 + unpack('N', $nullnullnull . ($byte_zero ^ $bit1));
	    } else {
		$pos = $pos + 3 + unpack('N', $null . substr($ip_db,$pos,3));
	    }
	} else {
	    # bit[$i] is unset [binary zero]
	    # jump to end of this node
	    # (start of child[0] node)
	    if (($byte_zero & $bit1) eq $bit1){
		$pos = $pos + 1;
	    } else {
		$pos = $pos + 3;
	    }
	}

	# all terminal nodes of the tree start with zeroth bit
	# set to zero. the first bit can then be used to indicate
	# whether we're using the first or second byte to store the
	# country code
	$byte_zero = substr($ip_db,$pos,1);
	if (($byte_zero & $bit0) eq $bit0){ # country code
	    if (($byte_zero & $bit1) eq $bit1){
		# unpopular country code - stored in second byte
		return $auth{substr($ip_db,$pos+1,1)};
	    } else {
		# popular country code - stored in bits 2-7
		# (we already know that bit 1 is not set, so
		# just need to unset bit 1)
		return $auth{$byte_zero ^ $bit0};
	    }
	}
    }
}

1;
__END__