1#!/usr/bin/perl -w
2use strict;
3$^W = 1;
4use Socket qw ( inet_aton inet_ntoa );
5use IO::File;
6print "Building registry... this will take a moment...\n";
7
8my %log2;
9for (my $i=0; $i<=31; $i++){
10    $log2{2 ** $i} = $i;
11}
12
13# this is our fast stash
14my $tree = IPTree->new();
15
16# and this is our pre-generated list of ranges
17my $reg_file = 'sorted_countries.txt';
18
19open (REG, "< $reg_file") || die("can't open $reg_file: $!");
20while (my $line = <REG>){
21    chomp $line;
22    next unless $line =~ /^([^\|]+)\|([^\|]+)\|(..)$/;
23    my ($ip,$size,$cc) = ($1,$2,$3);
24    $cc = 'CZ' if ($cc eq 'CS');
25    $cc = 'GB' if ($cc eq 'UK');
26    my $packed_ip = inet_aton($ip);
27    my $packed_range = substr(pack('N',$log2{$size}),3,1);
28    $tree->add($packed_ip,$packed_range,$cc);
29}
30close REG || warn("can't close $reg_file, but continuing: $!");
31
32
33print "Saving ultralite IP registry to disk\n";
34my $ip = new IO::File "> ../lib/IP/Country/Fast/ip.gif";
35if (defined $ip) {
36    binmode $ip;
37    print $ip pack("N",time()); # returned by $obj->db_time()
38    $tree->printTree($ip);
39    $ip->close();
40} else {
41    die "couldn't write IP registry:$!\n";
42}
43
44
45print "Saving ultralite country database to disk\n";
46
47open (CC, "> ../lib/IP/Country/Fast/cc.gif")
48    or die ("couldn't create country database: $!");
49binmode CC;
50foreach my $country (sort $tree->get_countries()){
51    print CC substr(pack('N',$tree->get_cc_as_num($country)),3,1).$country;
52}
53close(CC);
54print "Finished.\n";
55
56
57
58package IPTree;
59use strict;
60use Socket qw ( inet_aton inet_ntoa );
61$^W = 1;
62
63my @mask;
64my %ctod;
65my @dtoc;
66my $bit0;
67my $bit1;
68my $bits12;
69my $null;
70BEGIN {
71    $bit0 = substr(pack('N',2 ** 31),0,1);
72    $bit1 = substr(pack('N',2 ** 30),0,1);
73    $bits12 = substr(pack('N',2 ** 30 + 2 ** 29),0,1);
74    $null = substr(pack('N',0),0,1);
75    for (my $i = 1; $i <= 32; $i++){
76	$mask[$i] = pack('N',2 ** (32 - $i));
77    }
78
79    for (my $i=0; $i<=255; $i++){
80	$ctod{substr(pack('N',$i),3,1)} = $i;
81	$dtoc[$i] = substr(pack('N',$i),3,1);
82    }
83}
84
85sub new ()
86{
87    return bless {
88	countries => {}
89    }, 'IPTree';
90}
91
92sub add ($$$$)
93{
94    my ($tree,$ip,$packed_range,$cc) = @_;
95    $tree->_ccPlusPlus($cc);
96    my $netmask = 32 - $ctod{$packed_range};
97    for (my $i = 1; $i <= $netmask; $i++){
98	if (($ip & $mask[$i]) eq $mask[$i]){
99	    unless (exists $tree->{1}){
100		$tree->{1} = {};
101	    }
102	    $tree = $tree->{1};
103	} else {
104	    unless (exists $tree->{0}){
105		$tree->{0} = {};
106	    }
107	    $tree = $tree->{0};
108	}
109    }
110    $tree->{cc} = $cc;
111}
112
113sub get_cc_as_num ($)
114{
115    my ($self,$cc) = @_;
116    unless (exists $self->{sorted_cc}){
117	$self->{sorted_cc} = {};
118	my $i = 0;
119	foreach my $c (sort { $self->{countries}->{$b} <=> $self->{countries}->{$a} }
120		       keys %{$self->{countries}})
121	{
122	    $self->{sorted_cc}->{$c} = $i;
123	    $i++;
124	}
125    }
126    unless (exists $self->{sorted_cc}->{$cc}){
127	die("couldn't find $cc in country database");
128    }
129    return $self->{sorted_cc}->{$cc};
130}
131
132sub get_countries ()
133{
134    my ($self) = @_;
135    unless (exists $self->{sorted_cc}){
136	$self->get_cc_as_num('GB');
137    }
138    return sort keys %{$self->{sorted_cc}};
139}
140
141sub _ccPlusPlus ($)
142{
143    my ($self,$cc) = @_;
144    if (exists $self->{countries}->{$cc}){
145	$self->{countries}->{$cc}++;
146    } else {
147	$self->{countries}->{$cc} = 1;
148    }
149}
150
151sub printTree ($)
152{
153    my ($self,$fh) = @_;
154    _printSize($self,$self,$fh);
155}
156
157sub _printSize
158{
159    my ($self,$node,$fh) = @_;
160    if (exists $node->{cc}){
161	# country codes are one or two bytes -
162	# popular codes being stored in one byte
163	my $cc = $self->get_cc_as_num($node->{cc});
164	$cc = _encode_cc($cc);
165	print $fh $cc;
166    } else {
167	# jump distances are three bytes - might also be shrunk later
168	my $jump = _findSize($self,$node->{0});
169	my $binary_jump = _encode_size($jump);
170	print $fh $binary_jump;
171
172	_printSize($self,$node->{0},$fh);
173	_printSize($self,$node->{1},$fh);
174    }
175}
176
177sub _encode_cc
178{
179    my $cc = shift;
180    if ($cc < 64){
181	return $dtoc[$cc] | $bit0;
182    } else {
183	return $dtoc[255] . $dtoc[$cc];
184    }
185}
186
187sub _encode_size
188{
189    my $size = shift;
190    if ($size < 64){
191	return substr(pack('N',$size),3,1) | $bit1;
192    } else {
193	die ($size) if ($size >= 2**29);
194	return substr(pack('N',$size),1,3);
195    }
196}
197
198sub _findSize
199{
200    my ($self,$node) = @_;
201    my $size = 0;
202    if (exists $node->{cc}){
203	my $cc = $self->get_cc_as_num($node->{cc});
204	$size = length(_encode_cc($cc));
205    } else {
206	my $node_zero_size = $self->_findSize($node->{0});
207	my $node_one_size = $self->_findSize($node->{1});
208	$size = length(_encode_size($node_zero_size)) + $node_zero_size + $node_one_size;
209    }
210    return $size;
211}
212
2131;
214