IP::Country::DB_File::Builder - Build an IP address to country code database

 perl -MIP::Country::DB_File::Builder -e command -- -fbr

 use IP::Country::DB_File::Builder;

 fetch_files();
 my $builder = IP::Country::DB_File::Builder->new('ipcc.db');
 $builder->build();
 remove_files();

 ftp://ftp.arin.net/pub/stats/arin/delegated-arin-latest
 ftp://ftp.ripe.net/pub/stats/ripencc/delegated-ripencc-latest
 ftp://ftp.afrinic.net/pub/stats/afrinic/delegated-afrinic-latest
 ftp://ftp.apnic.net/pub/stats/apnic/delegated-apnic-latest
 ftp://ftp.lacnic.net/pub/stats/lacnic/delegated-lacnic-latest

 my $builder = IP::Country::DB_File::Builder->new([ $db_file ]);

 $builder->build([ $dir ]);

 fetch_files([ $dir ]);

 remove_files([ $dir ]);

 perl -MIP::Country::DB_File::Builder -e command -- [options] [dbfile]

package IP::Country::DB_File::Builder;
BEGIN {
  $IP::Country::DB_File::Builder::VERSION = '2.01';
}
use strict;

# ABSTRACT: Build an IP address to country code database

use vars qw(@ISA @EXPORT @rirs);

use DB_File ();
use Fcntl ();

BEGIN {
    require Exporter;
    @ISA = qw(Exporter);
    @EXPORT = qw(fetch_files remove_files command);

    # Regional Internet Registries
    @rirs = (
        { name=>'arin',    server=>'ftp.arin.net'    },
        { name=>'ripencc', server=>'ftp.ripe.net'    },
        { name=>'afrinic', server=>'ftp.afrinic.net' },
        { name=>'apnic',   server=>'ftp.apnic.net'   },
        { name=>'lacnic',  server=>'ftp.lacnic.net'  },
    );
}

sub new {
    my ($class, $db_file) = @_;
    $db_file = 'ipcc.db' unless defined($db_file);

    my $this = {
        range_count   => 0,
        address_count => 0,
    };

    my %db;
    my $flags = Fcntl::O_RDWR|Fcntl::O_CREAT|Fcntl::O_TRUNC;
    $this->{db} = tie(%db, 'DB_File', $db_file, $flags, 0666,
                      $DB_File::DB_BTREE)
        or die("Can't open database $db_file: $!");
    
    return bless($this, $class);
}

sub _store_ip_range {
    my ($this, $start, $end, $cc) = @_;

    my $key  = pack('N', $end - 1);
    my $data = pack('Na2', $start, $cc);
    $this->{db}->put($key, $data) >= 0 or die("dbput: $!");

    ++$this->{range_count};
    $this->{address_count} += $end - $start;
}

sub _store_private_networks {
    my $this = shift;

    # 10.0.0.0
    $this->_store_ip_range(0x0a000000, 0x0b000000, '**');
    # 172.16.0.0
    $this->_store_ip_range(0xac100000, 0xac200000, '**');
    # 192.168.0.0
    $this->_store_ip_range(0xc0a80000, 0xc0a90000, '**');
}

sub _import_file {
    my ($this, $file) = @_;
    
    my $seen_header;
    my @ranges;

    while(my $line = readline($file)) {
        next if $line =~ /^#/ or $line !~ /\S/;

        unless($seen_header) {
            $seen_header = 1;
            next;
        }

        my ($registry, $cc, $type, $start, $value, $date, $status) =
            split(/\|/, $line);

        next unless $type eq 'ipv4' && $start ne '*';

        # TODO (paranoid): validate $cc, $start and $value

        my $ip_num = unpack('N', pack('C4', split(/\./, $start)));

        push(@ranges, [ $ip_num, $value, $cc ]);
    }

    @ranges = sort { $a->[0] <=> $b->[0] } @ranges;

    my $count = 0;
    my $prev_start = 0;
    my $prev_end   = 0;
    my $prev_cc    = '';

    for my $range (@ranges) {
        my ($ip_num, $size, $cc) = @$range;

        if($ip_num == $prev_end && $prev_cc eq $cc) {
            # optimization: concat ranges of same country
            $prev_end += $size;
        }
        else {
            $this->_store_ip_range($prev_start, $prev_end, $prev_cc)
                if $prev_cc;

            $prev_start = $ip_num;
            $prev_end   = $ip_num + $size;
            $prev_cc    = $cc;
            ++$count;
        }
    }

    $this->_store_ip_range($prev_start, $prev_end, $prev_cc) if $prev_cc;
    
    return $count;
}

sub _sync {
    my $this = shift;

    $this->{db}->sync() >= 0 or die("dbsync: $!");
}

sub build {
    my ($this, $dir) = @_;
    $dir = '.' unless defined($dir);

    for my $rir (@rirs) {
        my $file;
        my $filename = "$dir/delegated-$rir->{name}";
        CORE::open($file, '<', $filename)
            or die("Can't open $filename: $!, " .
                   "maybe you have to fetch files first");

        eval {
            $this->_import_file($file);
        };

        my $error = $@;
        close($file);
        die($error) if $error;
    }

    $this->_store_private_networks();

    $this->_sync();
}

# functions

sub fetch_files {
    my ($dir, $verbose) = @_;
    $dir = '.' unless defined($dir);

    require Net::FTP;

    for my $rir (@rirs) {
        my $server = $rir->{server};
        my $name = $rir->{name};
        my $ftp_dir = "/pub/stats/$name";
        my $filename = "delegated-$name-latest";

        print("fetching ftp://$server$ftp_dir/$filename\n") if $verbose;

        my $ftp = Net::FTP->new($server)
            or die("Can't connect to FTP server $server: $@");
        $ftp->login('anonymous', '-anonymous@')
            or die("Can't login to FTP server $server: " . $ftp->message());
        $ftp->cwd($ftp_dir)
            or die("Can't find directory $ftp_dir on FTP server $server: " .
                   $ftp->message());
        $ftp->get($filename, "$dir/delegated-$name")
            or die("Get $filename from FTP server $server failed: " .
                   $ftp->message());
        $ftp->quit();
    }
}

sub remove_files {
    my $dir = shift;
    $dir = '.' unless defined($dir);

    for my $rir (@rirs) {
        my $name = $rir->{name};
        unlink("$dir/delegated-$name");
    }
}

sub command {
    require Getopt::Std;
    
    my %opts;
    Getopt::Std::getopts('vfbrd:', \%opts) or exit(1);
    
    die("extraneous arguments\n") if @ARGV > 1;
    
    my $dir = $opts{d};
    
    eval {
        fetch_files($dir, $opts{v}) if $opts{f};
    
        if($opts{b}) {
            print("building database...\n") if $opts{v};

            my $builder = __PACKAGE__->new($ARGV[0]);
            $builder->build($dir);

            # we define usable IPv4 address space as 1.0.0.0 - 223.255.255.255
            # excluding 127.0.0.0/8
             
            print(
                "total merged IP ranges: $builder->{range_count}\n",
                "total IP addresses: $builder->{address_count}\n",
                sprintf('%.2f', 100 * $builder->{address_count} / 0xde000000),
                "% of usable IPv4 address space\n",
            ) if $opts{v};
        }
    };

    if($@) {
        print STDERR ($@);
    }

    if($opts{r}) {
        print("removing statistics files\n") if $opts{v};
        remove_files($dir);
    }
}

1;

__END__