# -*- perl -*-
# Copyright (C) 2014 Sergey Poznyakoff <gray@gnu.org>
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3, or (at your option)
# any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

package Whoseip::DB;
    
use strict;
use Fcntl qw(SEEK_SET SEEK_CUR :flock);
use Socket qw(inet_ntoa);
use Storable qw(freeze thaw);
use Data::UUID;
use Data::Dumper;
use Carp;

require Exporter;
our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw(ipdb_open ipdb_lookup ipdb_insert
                                   ipdb_sync ipdb_locker ipdb_close
                                   ipdb_export ipdb_import) ] );

our @EXPORT_OK = ( qw(ipdb_open ipdb_lookup ipdb_insert
                      ipdb_sync ipdb_locker ipdb_close
                      ipdb_export ipdb_import) );

our @EXPORT = qw();

our $VERSION = "1.00";

my %ipv4_mask2len;
my @ipv4_len2mask;

BEGIN {
    my $ip = 0xffffffff;
    my $masklen = 32;
    for (my $i = 32; $i >= 0; $i--) {
	$ipv4_mask2len{$ip} = $masklen;
	unshift @ipv4_len2mask, $ip;
	$ip = ($ip << 1) & 0xffffffff;
	--$masklen;
    }
}

=pod

=head1 NAME

Whoseip::DB - WhoseIP cache database

=head1 SYNOPSIS

use Whoseip::DB;
use Whoseip::DB qw(:all);
    
$dbf = Whoseip::DB::ipdb_open($filename[,
                              pagesize => $psize,
                              cachesize => $csize]);    

$ref = Whoseip::DB::ipdb_lookup($ip);
print $ref->{country} if defined($ref);

Whoseip::DB::ipdb_insert($dbf, "192.0.2.0/24", 'US');

Whoseip::DB::ipdb_close($dbf);

=head1 DESCRIPTION

The B<Whoseip::DB> package provides functions for creating and accessing
a B<whoseip>(1) cache database.  This database is analogous to a GeoIP
database, except that it keeps more information.

The database is kept in a single file and consists of B<pages> of the
same size.  The file begins with a 512-byte header block of the following
structure:

B<Offset>      B<Size>        B<Description>
     0         8        "WHOSEIP\0"
     8         2        major version
    10         2        minor version
    12        16        UUID 
    28         4        page size
    32         4        number of allocated pages
    36         4        number of entries in root index table
    40       472        root index table

The first three fields serve to identify the file format and its version.
At the time of this writing, major and minor versions are B<1>.B<0>.

B<Page size> defines the size of the file page.  It defaults to 1280
bytes.    

Pages are of two types: B<index pages>, that serve to navigate through
the file, and B<leaf pages>, that keep actual data.  The B<root index
table>, located at the end of the file header keeps offsets of the
initial index page for IP addresses of different sizes kept in the
database.  Each entry in this table consists of two 32-bit words: the
first one keeps the length of the IP address in bits (e.g. 32 for IPv4
and 128 for IPv6), and the second one keeps the offset of the first
index table for entries of that size.  The table can accomodate at most
59 entries, which is more than enough for the purpose.

An B<index page> contains a table of offsets of the next page to look up
(whether index or leaf) and is indexed by the octet value (0 -- 255).
An extra slot keeps the offset of the leaf page.  The overall structure
of an index page is as follows:    

B<Offset>      B<Size>        B<Description>
     0         4        Index page type: B<1>
     4         4        OFF[0]
     8         4        OFF[1]
     .         .        .
     .         .        . 
     .         .        .
     1024      4        OFF[255]
     1028      4        OFF[LEAF]

When looking up for an IP address, index pages are descended starting
from the root page.  The octets of the IP address in host order are
iterated from left to right.  Each subsequent octet is used to select
offset of the next page from the current index page.  If the corresponding
offset is zero the last entry (B<OFF[LEAF]>) is used.  This process stops
when the B<leaf page> is encountered.

A B<leaf page> contains a table of B<CIDR>s and their descriptions.  Its
structure is as follows:    

B<Offset>      B<Size>        B<Description>
     0         4        Leaf page type: B<2>
     4         4        Number of entries in the table
     8         4        Offset of the continuation page (0 if none)
            
     12	       4	Entry 0: network address
     16	       4	Entry 0: network mask
     20	       4	Entry 0: timestamp
     24	       2	Entry 0: ISO 3166-1 country code
     26        4        Entry 0: length of additional data
     30        ?        Entry 0: additional data 
     .         .        .
     .         .        .
     .         .        .

     12+N*14   4        Entry N: network address           
     16+N*14   4	Entry N: network mask              
     20+N*14   4	Entry N: timestamp                 
     24+N*14   2	Entry N: ISO 3166-1 country code
     26+N*14   4        Entry N: length of additional data
     30+N*14   ?        Entry N: additional data 

When a leaf page is encountered, the IP address in question is compared
with each entry in turn using the usual procedure (B<AND>ing with the network
mask and comparing the result with the network address).  Search stops when
a matching entry is found.  Very large tables can span several leaf pages:    
if no entry matches in the current page, the search continues at the
continuation page whose offset is indicated by the third field.  If that
field is 0, the search returns failure.    
    
=cut    

my $dbsign = 'WHOSEIP';
my $vmajor = 1;
my $vminor = 0;

use constant IPDB_PAGE_INDEX => 1;
use constant IPDB_PAGE_LEAF => 2;

use constant LEAF_IDX => 256;

sub pagetypestr {
    my $t = shift;
    return "index" if ($t == IPDB_PAGE_INDEX);
    return "leaf" if ($t == IPDB_PAGE_LEAF);
    return $t;
}

sub systell { sysseek($_[0], 0, SEEK_CUR) }

my @ipdb_open_files;

sub ipdb_close_all {
    foreach my $file (@ipdb_open_files) {
	ipdb_close($file) if defined($file->{fd});
    }
}

END {
    ipdb_close_all();
}
    
=pod

=head2 B<I<$dbf> = Whoseip::DB::ipdb_open(I<$filename>>[B<,> I<options>]B<);>

Opens the database file I<$filename> and returns a descriptor to be used for
searches in that file.  I<options> is a hash that can contain the following
keys:

=over 4

=item B<pagesize>

Page size for the file.  This option is honoured only when creating the
file.  It cannot be less than 1032 bytes.  Default is 1280 bytes.

=item B<cachesize>    

Maximum number of pages to keep in a B<LRU> cache.  Defaults to 16.
    
=back    
    
=cut    
sub ipdb_open {
    my $filename = shift;
    local %_ = @_;
    my %ipdbfile;
    my $fd;
    if (-e $filename) {
	my $mode;

	if ($_{mode} eq 'ro') {
	    $ipdbfile{mode} = "<";
	} elsif ($_{mode} eq 'rw') {
	    $ipdbfile{mode} = "+<";
	} elsif (-w $filename) {
	    $ipdbfile{mode} = "+<";
	} else {
	    $ipdbfile{mode} = "<";
	}
	open($fd, $ipdbfile{mode}, $filename)
	    or croak "can't open $filename: $!";
	binmode $fd;
	croak "$filename is not a valid IP cache file"
	    unless sysread($fd, my $s, 512) == 512;
	my ($sign,$maj,$min,$uuid,$size,$np,$count,@tab) =
	    unpack('Z8 S S a16 L L L L*', $s);
	croak "$filename is not a valid IP cache file"
	    unless $sign eq $dbsign;
	croak "$filename is of wrong version ($maj.$min, expected $vmajor.$vminor)"
	    unless ($maj == $vmajor and $min == $vminor);
	croak "$filename: page size too small ($size)" if ($size < 1032);

	$ipdbfile{uuid} = $uuid;
	$ipdbfile{pagesize} = $size;
	$ipdbfile{numpages} = $np;
	
	for (my $i = 0; $i < $count; $i += 2) {
	    $ipdbfile{rootidx}->{$tab[$i]} = $tab[$i+1];
	    print STDERR "ROOTIDX $tab[$i]=$tab[$i+1]\n"
		if $_{debug} > 1;
	}
    } else {
	open($fd, "+>", $filename)
	    or croak "can't open $filename: $!";
	binmode $fd;
	$ipdbfile{pagesize} = defined($_{pagesize}) ? $_{pagesize} : 1280;
	$ipdbfile{numpages} = 0;
	my $ug = new Data::UUID;
	my $uuid = $ug->create();
	$ipdbfile{uuid} = $uuid;
	syswrite($fd, pack('Z8 S S a16 L L L @512',
			   $dbsign, $vmajor, $vminor, $uuid,
			   $ipdbfile{pagesize}, 0, 0));
    }
    $ipdbfile{filename} = $filename;
    $ipdbfile{fd} = $fd;
    $ipdbfile{maxpagecache} =
	defined($_{maxpagecache}) ? $_{maxpagecache} : 16;
    $ipdbfile{debug} = $_{debug};
    if ($ipdbfile{debug} > 1) {
	my $ug = new Data::UUID;
	print STDERR "file $filename, UUID ".$ug->to_string($ipdbfile{uuid})."\n";
    }
    $ipdbfile{ttl} = $_{ttl};
    push @ipdb_open_files, \%ipdbfile;
    return \%ipdbfile;
}

=pod

=head2 B<Whoseip::DB::ipdb_locker(I<$dbf>>[B<, I<opts>>]B<);>

Lock or unlock the database.
    
I<opts> is a hash of the following options:

=over 4

=item B<lock> => I<MODE>

Defines the locking operation.  I<MODE> is one of: B<exclusive> or B<LOCK_EX>,
B<shared> or B<LOCK_SH>, B<unlock> or B<LOCK_UN>.

If this option is not supplied, no locking will be done.  This is useful
to force syncronization with the disk state.    
    
=item B<sync> => B<0>|B<1>

When set to B<0>, disables synchronization with the disk file.  Default is
B<1>.

=back

=cut    
sub ipdb_locker {
    my ($dbf) = shift;
    local %_ = @_;

    my $mode;
    
    if ($_{lock} eq 'exclusive') {
	$mode = LOCK_EX;
    } elsif ($_{lock} eq 'shared') {
	$mode = LOCK_SH;
    } elsif ($_{lock} eq 'unlock') {
	$mode = LOCK_UN;
    } else {
	$mode = $_{lock};
    }

    if (defined($mode)) {
	flock($dbf->{fd}, $mode) or do {
	    carp "$dbf->{filename}: can't lock: $!";
	    return 0;
	};

	if ($mode == LOCK_UN) {
	    delete $dbf->{lockmode};
	} else {
	    $dbf->{lockmode} = $mode;
	}	
	return 1 if $mode == LOCK_UN;
    }

    return 1 if (defined($_{sync} and $_{sync} == 0));

    if (sysseek($dbf->{fd}, 0, SEEK_SET) != 0) {
	croak "$dbf->{filename}: can't seek: $!";
    }

    croak "$dbf->{filename}: read error: $!"
	unless sysread($dbf->{fd}, my $s, 512) == 512;
    
    my ($sign,$maj,$min,$uuid,$size,$np,$count,@tab) =
	unpack('Z8 S S a16 L L L L*', $s);

    if ($uuid ne $dbf->{uuid}) {
	print STDERR "$dbf->{filename}: disk file has changed\n"
	    if $dbf->{debug};

	# Re-initialize DB info
	$dbf->{uuid} = $uuid;
	$dbf->{pagesize} = $size;
	$dbf->{numpages} = $np;
	
	for (my $i = 0; $i < $count; $i += 2) {
	    $dbf->{rootidx}{$tab[$i]} = $tab[$i+1];
	    print STDERR "ROOTIDX $tab[$i]=$tab[$i+1]\n"
		if $_{debug} > 1;
	}

	# Invalidate the cache
	ipdb_cache_invalidate($dbf);
    }
	
    return 1;
}

sub ipdb_save_page($$) {
    my ($dbf, $page) = @_;


    my $ret;
    if ($page->{type} == IPDB_PAGE_INDEX) {
	print STDERR "saving index page $page->{off}: ".
	    join(',', @{$page->{tab}})."\n"
	    if $dbf->{debug} > 1;
	if (sysseek($dbf->{fd}, $page->{off}, SEEK_SET) != $page->{off}) {
	    croak "$dbf->{filename}: can't seek: $!";
	}
	$ret = syswrite($dbf->{fd}, pack('LL[257].',
					 $page->{type},
					 @{$page->{tab}},
					 $dbf->{pagesize}),
			$dbf->{pagesize});
	croak "$dbf->{file}: write error at $page->{off}: $ret: $!"
	    unless ($ret == $dbf->{pagesize});
	
	delete $page->{dirty};
    } elsif ($page->{type} == IPDB_PAGE_LEAF) {
        my $nextpage;
	do {
	    print STDERR "saving leaf page $page->{off}\n"
		if $dbf->{debug} > 1;
	    my $size = length(pack('LLL',0,0,0));
	    my $i = 0;
	    my $a;
	    foreach my $ent (@{$page->{tab}}) {
		my $x = pack('LLLa2L/a', @{$ent}[0 .. 3], freeze($ent->[4]));
		my $l = length($x);
		if ($size + $l > $dbf->{pagesize}) {
		    print STDERR "SPLIT at $i: $size + $l, rest ".
                                 ($#{$page->{tab}}-$i+1)."\n"
				 if $dbf->{debug} > 1;
		    $nextpage = ipdb_alloc_page($dbf, IPDB_PAGE_LEAF,
						nocache => 1);
		    $page->{next} = $nextpage->{off};
		    @{$nextpage->{tab}} = @{$page->{tab}}[$i .. $#{$page->{tab}}];
		    $nextpage->{dirty} = 1;
		    splice @{$page->{tab}}, $i;
		    last;
		}
		$size += $l;
		$a .= $x; 
		++$i;
	    }
	    if (sysseek($dbf->{fd}, $page->{off}, SEEK_SET) != $page->{off}) {
		croak "$dbf->{filename}: can't seek: $!";
	    }
	    $ret = syswrite($dbf->{fd},
			    pack('LLLa'.length($a).'@'.$dbf->{pagesize},
				 $page->{type},
				 $i,
				 $page->{next},
				 $a));
	    croak "$dbf->{file}: write error at $page->{off}: $ret: $!"
		unless ($ret == $dbf->{pagesize});
            delete $page->{dirty};
            $page = $nextpage;
            $nextpage = undef;
	} while (defined($page)); 

    } else {
	croak "unrecognized page type ($page->{type})";
    }
}

sub ipdb_cache_invalidate($) {
    my $dbf = shift;

    $dbf->{pagecache} = ();
}
    
sub ipdb_cache_put($$) {
    my ($dbf,$page) = @_;
    if (keys(%{$dbf->{pagecache}}) >= $dbf->{maxpagecache}) {
	my $prev = $dbf->{pagecache}{lru_oldest}{lru_newer};
	if ($dbf->{pagecache}{lru_oldest}{dirty}) {
	    ipdb_save_page($dbf, $dbf->{pagecache}{lru_oldest});
	}
	delete $dbf->{pagecache}{$dbf->{pagecache}{lru_oldest}{off}};
	$dbf->{pagecache}{lru_oldest} = $prev;
	delete $prev->{lru_older};
    }
    my $n = $dbf->{pagecache}{lru_newest};
    if (defined($n)) {
	$n->{lru_newer} = $page;
    }
    $page->{lru_newer} = undef;
    $page->{lru_older} = $n;
    $dbf->{pagecache}{lru_newest} = $page;
    $dbf->{pagecache}{lru_oldest} = $page 
	unless defined $dbf->{pagecache}{lru_oldest};
    $dbf->{pagecache}{$page->{off}} = $page;
    dump_lru($dbf, "put $page->{off}");
}

sub dump_lru {
    my ($dbf,$pfx) = @_;

    return unless $dbf->{debug} > 2;

    my $x = $dbf->{pagecache}{lru_oldest};
    print STDERR "DUMP $pfx\n";
    print STDERR "KEYS: ".join(',', sort keys %{$dbf->{pagecache}})."\n";
    while (defined($x)) {
	print STDERR "==> $x->{off} (".pagetypestr($x->{type}).",";

	if (defined($x->{lru_newer})) {
	    print STDERR $x->{lru_newer}{off};
	} else {
	    print STDERR "NIL";
	}
	print STDERR ",";
	if (defined($x->{lru_older})) {
	    print STDERR $x->{lru_older}{off};
	} else {
	    print STDERR "NIL";
	}
	print STDERR ")\n";
	$x = $x->{lru_newer};
    }
    print STDERR "END\n";
}
	
sub ipdb_cache_get($$) {
    my ($dbf,$off) = @_;
    my $page;
    if (defined($dbf->{pagecache}{$off})) {
	print STDERR "$off found in cache: ".
              pagetypestr($dbf->{pagecache}{$off}{type})."\n" if $dbf->{debug};
	$page = $dbf->{pagecache}{$off};
	if (defined($page->{lru_newer})) {
	    print STDERR "promoting $page->{off}\n" if $dbf->{debug} > 2;
	    # promote the page
	    if (defined($page->{lru_older})) {
		$page->{lru_older}{lru_newer} = $page->{lru_newer};
	    } else {
		# It was the oldest page
		$dbf->{pagecache}{lru_oldest} = $page->{lru_newer};
	    }

	    $page->{lru_newer}{lru_older} = $page->{lru_older};

	    $page->{lru_older} = $dbf->{pagecache}{lru_newest};
	    $dbf->{pagecache}{lru_newest}{lru_newer} = $page;

	    $dbf->{pagecache}{lru_newest} = $page;

	    $page->{lru_newer} = undef;
	    $dbf->{pagecache}{lru_oldest} = $page 
		unless defined $dbf->{pagecache}{lru_oldest};
	    dump_lru($dbf, "after promoting $page->{off}");
	}
    } else {
	print STDERR "$off NOT found in cache\n" if $dbf->{debug};
	$page = ipdb_get_page($dbf, $off);
	ipdb_cache_put($dbf, $page);
    }
    return $page;
}

=pod

=head2 B<Whoseip::DB::ipdb_sync(I<$dbf>);>

Sunchronizes the database with the disk.

=cut

sub ipdb_sync($) {
    my $dbf = shift;
    if ($dbf->{modified}) {
	croak "$dbf->{filename}: can't seek: $!"
	    if (sysseek($dbf->{fd}, 0, SEEK_SET) != 0);

	my $ug = new Data::UUID;
	$dbf->{uuid} = $ug->create();
	
	my $n = syswrite($dbf->{fd},
			 pack('Z8 S S a16 L L L L* @512',
			      $dbsign, $vmajor, $vminor, $dbf->{uuid},
			      $dbf->{pagesize}, $dbf->{numpages},
			      keys(%{$dbf->{rootidx}})+0,
			      map { $_, $dbf->{rootidx}{$_} }
			        keys %{$dbf->{rootidx}}));
	croak "$dbf->{filename}: write error at header: $n: $!"
	    unless ($n == 512);
	$dbf->{modified} = 0;
    }
    while (my ($off, $page) = each %{$dbf->{pagecache}}) {
	ipdb_save_page($dbf, $page) if $page->{dirty};
    }
}

=pod

=head2 B<Whoseip::DB::ipdb_close(I<$dbf>);>

Close the database.  I<$dbf> is the handle returned from the
previous call to B<ipdb_open>.    
    
=cut    
sub ipdb_close($) {
    my $dbf = shift;
    ipdb_locker($dbf, lock => LOCK_EX, sync => 0);
    ipdb_sync($dbf);
    ipdb_locker($dbf, lock => LOCK_UN);
    close $dbf->{fd};
    delete $dbf->{fd};
}

sub ipdb_get_page($$) {
    my ($dbf,$off) = @_;
    my %ret;

    if (sysseek($dbf->{fd}, $off, SEEK_SET) != $off) {
	croak "$dbf->{filename}: can't seek: $!";
    }

    my $n = sysread($dbf->{fd}, my $s, $dbf->{pagesize});
    unless (defined($n)) {
	croak "$dbf->{filename}: can't read page: $!";
    } elsif ($n != $dbf->{pagesize}) {
	croak "$dbf->{filename}: short read ($n < $dbf->{pagesize})";
    }

    $ret{type} = unpack('L', $s);
    $ret{off} = $off;
    if ($ret{type} == IPDB_PAGE_INDEX) {
	print STDERR "loaded index page at $off\n" if $dbf->{debug} > 3;
	my ($x, @a) = unpack('LL257', $s);
	$ret{tab} = \@a;
    } elsif ($ret{type} == IPDB_PAGE_LEAF) {
	(my $x, my $nent, $ret{next}) =
	    unpack('LLL', $s);
	print STDERR "loaded leaf page at $off, has $nent entries\n"
	    if $dbf->{debug} > 3;	
	my ($x1, $x2, $x3, @a) = unpack("LLL(LLLa2L/a)$nent", $s);
	for (my $i = 0; $i < $nent; $i++) {
	    my $href = thaw $a[$i*5 + 4];
	    if ($dbf->{debug} > 3) {
		print STDERR "[$i] = ".join(' ', @a[$i*5 .. $i*5 + 3]).'; (';
		while (my ($k,$v) = each %{$href}) {
		    print STDERR "$k => $v, ";
		}
		print STDERR ")\n";
	    }
	    push @{$ret{tab}}, [ @a[$i*5 .. $i*5 + 3], $href ];
	}
    } else {
	croak "$dbf->{filename}: invalid page type $ret{type} at offset $off";
    }
	
    return \%ret;    
}

sub ipdb_alloc_page($$) {
    my ($dbf,$type) = @_;
    my %page;
    local %_ = @_;
    
    $page{type} = $type;
    $page{off} = $dbf->{numpages}++ * $dbf->{pagesize} + 512;
    if ($type == IPDB_PAGE_INDEX) {
	$#{$page{tab}} = 256;
    } else {
	$page{next} = 0;
	$#{$page{tab}} = -1;
    }
    
    print STDERR "new ".pagetypestr($type)." page at $page{off}\n"
	if $dbf->{debug};

    $page{dirty} = 1;
    ipdb_cache_put($dbf, \%page) unless ($_{nocache});
    ++$dbf->{modified};
    return \%page;
}

sub ipdb_get_root_page($$) {
    my ($dbf,$nbits) = @_;
    my $p;

    if (!defined($dbf->{rootidx}{$nbits})) {
	$p = ipdb_alloc_page($dbf, IPDB_PAGE_INDEX);
	print STDERR "root page for $nbits: created at $p->{off}\n"
	    if $dbf->{debug} > 2;
	$dbf->{rootidx}{$nbits} = $p->{off};
	$dbf->{modified}++;
    } else {
	print STDERR "root page for $nbits: $dbf->{rootidx}{$nbits}\n"
	    if $dbf->{debug} > 2;
	$p = ipdb_cache_get($dbf, $dbf->{rootidx}{$nbits});
    }
    return $p;
}


=pod

=head2 $res = B<Whoseip::DB::ipdb_lookup(I<$dbf>, I<$ip>);>

Look up IP address I<$ip> in the database identified by I<$dbf> (a handle
returned by the previous call to B<ipdb_open>.  If found, B<$ref> is a
reference to a hash that contains the following keys:

=over 4

=item B<country>

ISO 3166-1 country code

=item B<network>

Network address in a dotted-quad form.

=item B<netmask>

Network mask in a dotted-quad form.

=back

If not found, the function returns B<undef>.    

=cut    
sub ipdb_lookup_unlocked($$) {
    my ($dbf,$ipstr) = @_;
    my @ipo;
    my $ipn;
    my $nbits;

    if ($ipstr =~ /^\d{1,3}((\.\d{1,3}){3})$/) {
	@ipo = split(/\./, $ipstr);
	$ipn = ($ipo[0] << 24) + ($ipo[1] << 16) + ($ipo[2] << 8) + $ipo[3];
	$nbits = 32;
    } else {
	print STDERR "ipdb_lookup: unsupported IP address $ipstr\n"
	    if $dbf->{debug};
	return undef;
    }

    print STDERR "ipdb_lookup: looking up for $ipstr\n"
	if $dbf->{debug};
    my $page = ipdb_get_root_page($dbf, $nbits);
    my $n = 0;
    my @leafstk;
    while ($page->{type} == IPDB_PAGE_INDEX) {
	print STDERR "index page $page->{off}: ".
	    join(',', @{$page->{tab}})."\n"
	    if $dbf->{debug} > 1;
	print STDERR "ipdb_lookup: octet ${n}=$ipo[$n], off=$page->{tab}[$ipo[$n]]\n"
	    if $dbf->{debug};
	push @leafstk, $page->{tab}[LEAF_IDX] if $page->{tab}[LEAF_IDX];
	if ($page->{tab}[$ipo[$n]]) {
	    $page = ipdb_cache_get($dbf, $page->{tab}[$ipo[$n]]);
	    ++$n;
	} else {
	    last;
	}
    }

    if ($dbf->{debug}) {
	print STDERR "ipdb_lookup: $ipstr: descended to ".
	             join('.', @ipo[0..$n]);
	if ($#leafstk >= 0) {
	    print STDERR ", now rescanning leaf stack (".($#leafstk + 1).
		         " entries)\n";
	} else {
	    print STDERR ", found nothing";
	}
	print STDERR "\n";
    }
    
    while (my $off = pop @leafstk) {
	$page = ipdb_cache_get($dbf, $off);

	my $i = 0;
	foreach my $r (@{$page->{tab}}) {
	    print STDERR "ipdb_lookup: compare ($ipn & $r->[1]) == $r->[0]\n"
		if $dbf->{debug};
	    if (($ipn & $r->[1]) == $r->[0]) {
		print STDERR "ipdb_lookup: MATCH $r->[3]\n"
		    if $dbf->{debug};
		if (defined($dbf->{ttl}) and
		    (time - $r->[2]) > $dbf->{ttl}) {
		    print STDERR "ipdb_lookup: record expired, removing\n"
			if $dbf->{debug};
		    splice @{$page->{tab}}, $i, 1;
		    $page->{dirty} = 1;
		    return undef;
		}
		my %res = ( country => $r->[3],
			    network => inet_ntoa(pack('N', $r->[0])),
			    netmask => inet_ntoa(pack('N', $r->[1])),
		            timestamp => $r->[2],
			    package => 'whoseip',
		            version => $VERSION );
		$res{ttl} = $dbf->{ttl} - (time - $r->[2])
		    if (defined($dbf->{ttl}));
		@res{keys %{$r->[4]}} = values %{$r->[4]}
		    if (defined($r->[4]) and ref($r->[4]) eq 'HASH');
		return %res;
	    }
	    ++$i;
	}
	push @leafstk, $page->{next} if ($page->{next});
    }
    return undef;
}

sub ipdb_lookup($$) {
    my ($dbf) = @_;

    if ($dbf->{lockmode} == LOCK_EX) {
	return &ipdb_lookup_unlocked;
    } elsif ($dbf->{lockmode} == LOCK_SH) {
	ipdb_locker($dbf, sync => 1);
	return &ipdb_lookup_unlocked;
    } else {     
	ipdb_locker($dbf, lock => LOCK_SH);
	my %res = &ipdb_lookup_unlocked;
	ipdb_locker($dbf, lock => LOCK_UN);
	return %res;
    }
}

=pod

=head2 $res = B<Whoseip::DB::ipdb_insert(I<$dbf>, I<$cidr>, I<$country>>[B<, I<$hashref>>]B<);>

Inserts into the database I<$cidr> and the corresponding country code I<$country>
and additional data I<$hashref>.

Currently, I<$cidr> must be in the form B<I<Net-address>/I<Netmask-length>>.    
    
=cut    
sub ipdb_insert_unlocked {
    my ($dbf, $cidr, $country, $href) = @_;
    my @ipo;
    my $ipn;
    my $masklen;
    my $netmask;
    my $nbits;

    return 0 if ($dbf->{mode} eq '<');
    
    if ($cidr =~ m#^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})/(\d+)$#) {
	@ipo = ( $1, $2, $3, $4 );
	$ipn = ($1 << 24) + ($2 << 16) + ($3 << 8) + $4;
	$masklen = $5;
	$netmask = (0xffffffff ^ (0xffffffff >> $masklen));
	$nbits = 32;
    } else {
	carp "invalid CIDR: $cidr";
	return 0;
    }

    print STDERR "ipdb_insert: inserting $cidr $country\n" if $dbf->{debug};

    my $n = int($masklen / 8);

    my $page = ipdb_get_root_page($dbf, $nbits);
    for (my $i = 0; $i < $n; $i++) {
	if ($page->{tab}[$ipo[$i]]) {
	    print STDERR "ipdb_insert: octet ${i}=$ipo[$i], off=$page->{tab}[$ipo[$i]]\n"
		if $dbf->{debug};
	    $page = ipdb_cache_get($dbf, $page->{tab}[$ipo[$i]]);
	} else {
	    my $p = ipdb_alloc_page($dbf, IPDB_PAGE_INDEX);
	    $page->{tab}[$ipo[$i]] = $p->{off};
	    $page->{dirty} = 1;
	    $page = $p;
	}
    }

    if ($page->{tab}[LEAF_IDX]) {
	print STDERR "ipdb_insert: loading leaf page from $page->{tab}[LEAF_IDX]\n"
	    if $dbf->{debug};
	$page = ipdb_cache_get($dbf, $page->{tab}[LEAF_IDX]);
	croak "$dbf->{filename}: index page found where leaf was expected"
	    unless $page->{type} == IPDB_PAGE_LEAF;
    } else {
	print STDERR "ipdb_insert: creating leaf page\n"
	    if $dbf->{debug};
	my $p = ipdb_alloc_page($dbf, IPDB_PAGE_LEAF);
	$page->{tab}[LEAF_IDX] = $p->{off};
	$page->{dirty} = 1;
	$page = $p;
    }

    push @{$page->{tab}}, [ $ipn, $netmask, time(), $country, $href ];
    $page->{dirty} = 1;

    return 1;
}

sub ipdb_insert {
    my ($dbf) = @_;

    return &ipdb_insert_unlocked if ($dbf->{lockmode});

    ipdb_locker($dbf, lock => LOCK_EX);
    my $res = &ipdb_insert_unlocked;
    ipdb_sync($dbf);
    ipdb_locker($dbf, lock => LOCK_UN);
    return $res;
}

sub ipdb_dump_page {
    my ($dbf, $off, $fd) = @_;
    my $page = ipdb_get_page($dbf, $off);
    if ($page->{type} == IPDB_PAGE_INDEX) {
	ipdb_dump_page($dbf, $page->{tab}[LEAF_IDX], $fd)
	    if $page->{tab}[LEAF_IDX];
	foreach my $off (@{$page->{tab}}[0 .. LEAF_IDX - 1]) {
	    ipdb_dump_page($dbf, $off, $fd) if $off;
	}
    } elsif ($page->{type} == IPDB_PAGE_LEAF) {
	do {
	    foreach my $r (@{$page->{tab}}) {
		$r->[0] = inet_ntoa(pack('N', $r->[0]));
		if (defined($ipv4_mask2len{$r->[1]})) {
		    $r->[1] = $ipv4_mask2len{$r->[1]};
		    my $v = Dumper($r);
		    print $fd "$v\n";
		} else {
		    print STDERR "ignoring invalid entry " .
			         $r->[0] . '/' .
				 inet_ntoa(pack('N', $r->[1]))
		}
	    }
	    $page = $page->{next} ? ipdb_get_page($dbf, $page->{next}) : undef;
	} while ($page);
    }
}

=pod

=head1 B<Whoseip::DB::ipdb_export(I<$dbf>>[B<, I<$fd>>]B<);>

Exports database I<$dbf> in a portable plain-text format to
file identified by I<$fd> (B<STDOUT> by default).
    
The created file can be transferred over the network and used
to recreate the database via B<Whoseip::DB::ipdb_import>.

=cut    
    
sub ipdb_export {
    my ($dbf, $fd) = @_;

    $fd = *STDOUT unless defined($fd);

    my $ug = new Data::UUID;

    print $fd "# Whoseip dump from file $dbf->{filename}\n";
    print $fd "# UUID ".$ug->to_string($dbf->{uuid})."\n";
    local $Data::Dumper::Indent = 0;
    local $Data::Dumper::Terse = 1;
    foreach my $off (values %{$dbf->{rootidx}}) {
	ipdb_dump_page($dbf, $off, $fd);
    }
}

=pod

=head1 B<$res = Whoseip::DB::ipdb_import(I<$dbf>>[B<, I<$fd>>]B<);>

Imports data from the file descriptor I<$fd> (B<STDIN> by default)
into the database file I<$dbf>.  Returns 1 on success and 0 on
failure.

=cut    
    
sub ipdb_import {
    my ($dbf, $fd) = @_;

    $fd = *STDIN unless defined($fd);

    ipdb_locker($dbf, lock => LOCK_EX);
    my $line = 0;
    while (<$fd>) {
	++$line;
	chomp;
	next if /^#/;
	my $r = eval $_;
	if ($@) {
	    print STDERR "ipdb_import: error in line $line: $@\n";
	    return 0;
	}
	my $cidr = "$r->[0]/$r->[1]";
	ipdb_insert_unlocked($dbf, $cidr, $r->[3], $r->[4]);
    }
    ipdb_sync($dbf);
    ipdb_locker($dbf, lock => LOCK_UN);
    return 1;
}
1;

