Net-Whois-IP/IP.pm

=head1 NAME

Net::Whois::IP - find whois data for ip addresses

=head1 SYNOPSIS

 use Net::Whois::IP;

=head1 DESCRIPTION

=over 4

=cut

# http://www.irr.net/docs/rpsl.html

package Net::Whois::IP;

BEGIN {
   $VERSION = 0.01;
   @EXPORT_OK = qw();
}

use base Exporter;

use Carp;

use Socket;

use BerkeleyDB;

use Coro;
use Coro::Event;
use Coro::Semaphore;
use Coro::SemaphoreSet;
use Coro::Socket;
use Coro::Timer;
use Coro::Channel;

my %server;

sub new_btree {
   new BerkeleyDB::Btree
       -Env => $db_env,
       -Filename => $_[0],
       -Flags => DB_CREATE,
          or die "$_[0]: unable to create/open table";
}

package Net::Whois::IP::base;

sub new {
   my $class = shift;
   my $self = bless {
      name => @_,
   }, $class;
   $self->{request} ||= new Coro::Channel $self->{request_backlog} || 10;
   $self->{daemon} = Coro::async { shift->_daemon } $self;
   $self->{cache} = Net::Whois::IP::new_btree "whois_" . lc $self->{name};
   $server{$self->{name}} = $self;
}

sub _failure {
   my $self = shift;
   undef $self->{fh};
   Coro::Timer::sleep 1.5 ** $self->{retry} - 2 if $self->{retry};
   $self->{retry}++ if $self->{retry} < 17;
}

sub _ok {
   my $self = shift;
   $self->{retry} = 0;
}

sub _query {
   my ($self, $query) = @_;

   my $response;

   if (!$self->{cache}->db_get($query, $response)) {
      $response =~ s/^[^\x00]+\x00//;
      return $response;
   }

   my $request = {
      ready => (new Coro::Semaphore 0),
      query => $query,
   };

   $self->{request}->put($request);
   $request->{ready}->down;

   $response = time . "\x00" . $request->{response};

   $self->{cache}->db_put($query, $response);
   
   $request->{response};
}

sub ip_query {
   my ($self, $ip) = @_;
   $self->_query($ip);
}

sub parse_ip_response {
   my ($self, $response) = @_;
   my %response;
   while ($response =~ /^([^:]+):[ \t]*(.*)$/mg) {
      push @{$response{$1}}, $2;
   }
   \%response;
}

package Net::Whois::IP::whois;

# plain whois, as used by ripe and apnic

use base Net::Whois::IP::base;

sub _daemon {
   my $self = shift;
   while (my $request = $self->{request}->get) {
      my $fh = new Coro::Socket PeerHost => $self->{server}
         or $self->_failure, redo;

      $fh->print("$request->{query}\012");
      $fh->sysread($request->{response}, 16384);
      length $request->{response}
         or $self->_failure, redo;

      $self->_ok;
      $request->{ready}->up;
   }
}

sub ip_query {
   my ($self, $ip) = @_;
   $self->SUPER::ip_query($ip);
}

sub parse_ip_response {
   my ($self, $response) = @_;
   $response =~ s/^%.*//mg;
   $response =~ s/^\012+//;
   $response =~ s/\012\012.*//s;
   $self->SUPER::parse_ip_response($response);
}

package Net::Whois::IP::jpnic;

# totally different result format

use base Net::Whois::IP::whois;

sub ip_query {
   my ($self, $ip) = @_;
   $self->SUPER::ip_query("$ip/e");
}

sub parse_ip_response {
   my ($self, $response) = @_;
   $response =~ s/^\[\s.*//mg;
   $response =~ s/^(?:\w\.\ )? \[ ([^\]]+) \] (.*) (?:\012(?=\s))?/$1: $2/mgx;
   $self->SUPER::parse_ip_response($response);
}

package Net::Whois::IP::ripe;

# keepalive whois, as used by ripe and apnic

use base Net::Whois::IP::whois;

sub _daemon {
   my $self = shift;
   my $fh;

   while (my $request = $self->{request}->get) {
      unless ($self->{fh}) {
         $fh = new Coro::Socket PeerHost => $self->{server};
         $fh or $self->_failure, redo;
      }

      $fh->print("-k $request->{query}\012");
      $request->{response} = $fh->readline("\012\012\012");
      length $request->{response}
         or $self->_failure, redo;

      $self->_ok;
      $request->{ready}->up;
   }
}

package Net::Whois::IP::rwhois;

# rwhois 1.5

use base Net::Whois::IP::base;

sub _request {
   my $self = shift;
   my ($response, $error);

   $self->{fh}->print("$_[0]\015\012");
   while (defined (my $line = $self->{fh}->readline)) {
      $line =~ s/[\015\012]+$/\n/g;
      $response .= $line;
      $line =~ /^%(ok|error)/ and return $response;
   }
   return;
}

sub _daemon {
   my $self = shift;
   while (my $request = $self->{request}->get) {
      unless ($self->{fh}) {
         $self->{fh} = new Coro::Socket PeerHost => $self->{server};
         $self->{fh} or $self->_failure, redo;
         $self->{fh}->readline =~ /^%rwhois / or $self->_failure, redo;
         $self->_request("-rwhois V-1.5 Net::Whois::IP") or $self->_failure, redo;
         $self->_request("-forward off") or $self->_failure, redo;
         $self->_request("-holdconnect on") or $self->_failure, redo;
      }
      $request->{response} = $self->_request($request->{query})
         or $self->_failure, redo;
      $request->{response} =~ s/^%error 330.*/%ok/m;
      $self->_ok;
      $request->{ready}->up;
   }
}

sub ip_query {
   my ($self, $ip) = @_;
   $self->SUPER::ip_query("network $ip");
}

sub parse_ip_response {
   my ($self, $response) = @_;
   $response =~ s/^([^:]+):([^:]+):/$1-\L$2: /mg;
   $response =~ s/^%.*//mg;
   $response =~ s/\012\012.*//s;
   $self->SUPER::parse_ip_response($response);
}

package Net::Whois::IP;

sub ip_range {
   my $range = $_[0];

   if ($range =~ /^
            (2[0-5][0-9]|1[0-9][0-9]|[1-9][0-9]|[0-9])
            (?:\.
               (2[0-5][0-9]|1[0-9][0-9]|[1-9][0-9]|[0-9])
               (?:\.
                  (2[0-5][0-9]|1[0-9][0-9]|[1-9][0-9]|[0-9])
                  (?:\.
                     (2[0-5][0-9]|1[0-9][0-9]|[1-9][0-9]|[0-9])
                  )?
               )?
            )?
            \/
            ([0-9]+)
         $/x) {
      my $ip   = inet_aton sprintf "%d.%d.%d.%d", $1, $2, $3, $4;
      my $net  = 1 << (31 - $5);
      my $mask = inet_aton 2 ** 32 - $net;

      my $ip1 = $ip & $mask;
      my $ip2 = $ip1 | inet_aton $net * 2 - 1;
      return unpack "N2", "$ip1$ip2";
   } elsif ($range =~ /^\s*([0-9.]+)\s*-\s*([0-9.]+)\s*$/) {
      unpack "N2", pack "N2", $1, $2;
   } else {
      die "$range: unable to parse ip range";
   }
}

# add a referral to a specific server
sub add_referral {
   my ($netblock, $server) = @_;
   my ($ip0, $ip1) = ip_range $netblock;
   $db_referral->db_put((pack "N*", $ip1, $ip0) ^ "\x00\x00\x00\x00\xff\xff\xff\xff", "S" . $server->{name});
}

# get all referrals
sub parse_referral {
   my ($query, $server) = @_;
   my $referral = $arin->_query("referral $query");

   while ($referral =~ /^referral:Referred-Auth-Area:([0-9.\/]+)$/mg) {
      add_referral $1, $server;
   }
}

sub init(;%) {
   my (%arg) = @_;
   $arg{db_home} or $arg{db_env} or Carp::croak "either db_home or db_env home must be set";
   $db_env = $arg{db_env} || do {
      mkdir $arg{db_home}, 0700;

      $db_env = new BerkeleyDB::Env
           -Home => $arg{db_home},
           -Cachesize => $arg{db_cachesize} || 1_000_000,
           -ErrFile => $arg{db_errfile} || "/dev/fd/2",
           -ErrPrefix => "NET-WHOIS-IP",
           -Verbose => 1,
           -Flags => DB_CREATE|DB_RECOVER|DB_INIT_MPOOL|DB_INIT_TXN
              or die "$arg{db_home}: unable to create database home";
   };

   $arin   = new Net::Whois::IP::rwhois "ARIN",   server => "rwhois.arin.net:rwhois(4321)";

   $ripe   = new Net::Whois::IP::ripe   "RIPE",   server => "whois.ripe.net:whois(43)";
   $lacnic = new Net::Whois::IP::whois  "LACNIC", server => "whois.lacnic.net:whois(43)";
   $brnic  = new Net::Whois::IP::whois  "BRNIC",  server => "whois.registro.br:whois(43)";
   $apnic  = new Net::Whois::IP::ripe   "APNIC",  server => "whois.apnic.net:whois(43)";
   $jpnic  = new Net::Whois::IP::jpnic  "JPNIC",  server => "whois.nic.ad.jp:whois(43)";

   $db_referral = new_btree "referral";

   add_referral "129.13.0.0/16", $ripe;
   add_referral "200.0.0.0/8", $lacnic;
   add_referral "200.128.0.0/9", $brnic;

   parse_referral "32.0.0.0", $ripe;
   parse_referral "202.0.0.0", $apnic;
   parse_referral "192.50.0.0", $apnic;

   add_referral "133.0.0.0/8", $jpnic;
}

###

init db_home => "/tmp/whois";

sub ip_query {
   my $ip = shift;

   print "Q?$ip ";

   my $server = $arin;

   my $c = $db_referral->db_cursor;

   my ($k, $v) = (inet_aton $ip);
   if (!$c->c_get($k, $v, DB_SET_RANGE)) {
      my ($ip1, $ip0) = unpack "N*", $k ^ "\x00\x00\x00\x00\xff\xff\xff\xff";
      my $ipn = unpack "N", inet_aton $ip;

      if ($ip0 <= $ipn && $ipn <= $ip1) {
         if ($v =~ s/^S//) {
            $server = $server{$v} if $server{$v};
         } elsif ($v =~ s/^I//) {
            die;
         } else {
            # database corrupted or newer
         }
      }
   }

   print "($ip,$server->{name})\n";
   $server->parse_ip_response($server->ip_query($ip));
}

for (qw(132.64.0.0 129.13.162.91 193.166.90.111 213.189.83.103 161.142.8.76 66.68.103.189 200.149.85.112 210.49.200.207 133.11.128.254)) {
   use PApp::Util;
   warn PApp::Util::dumpval ip_query($_);
}

exit;

__END__

1;

=back

=head1 AUTHOR

 Marc Lehmann <pcg@goof.com>
 http://www.goof.com/pcg/marc/

=cut

Revision:	1.2
Committed:	Sat Nov 30 02:45:47 2002 UTC (21 years, 5 months ago) by root
Branch:	MAIN
Changes since 1.1:	+347 -2 lines
Log Message:	* empty log message *
#	Content
1	=head1 NAME
2
3	Net::Whois::IP - find whois data for ip addresses
4
5	=head1 SYNOPSIS
6
7	use Net::Whois::IP;
8
9	=head1 DESCRIPTION
10
11	=over 4
12
13	=cut
14
15	# http://www.irr.net/docs/rpsl.html
16
17	package Net::Whois::IP;
18
19	BEGIN {
20	$VERSION = 0.01;
21	@EXPORT_OK = qw();
22	}
23
24	use base Exporter;
25
26	use Carp;
27
28	use Socket;
29
30	use BerkeleyDB;
31
32	use Coro;
33	use Coro::Event;
34	use Coro::Semaphore;
35	use Coro::SemaphoreSet;
36	use Coro::Socket;
37	use Coro::Timer;
38	use Coro::Channel;
39
40	my %server;
41
42	sub new_btree {
43	new BerkeleyDB::Btree
44	-Env => $db_env,
45	-Filename => $_[0],
46	-Flags => DB_CREATE,
47	or die "$_[0]: unable to create/open table";
48	}
49
50	package Net::Whois::IP::base;
51
52	sub new {
53	my $class = shift;
54	my $self = bless {
55	name => @_,
56	}, $class;
57	$self->{request} \|\|= new Coro::Channel $self->{request_backlog} \|\| 10;
58	$self->{daemon} = Coro::async { shift->_daemon } $self;
59	$self->{cache} = Net::Whois::IP::new_btree "whois_" . lc $self->{name};
60	$server{$self->{name}} = $self;
61	}
62
63	sub _failure {
64	my $self = shift;
65	undef $self->{fh};
66	Coro::Timer::sleep 1.5 ** $self->{retry} - 2 if $self->{retry};
67	$self->{retry}++ if $self->{retry} < 17;
68	}
69
70	sub _ok {
71	my $self = shift;
72	$self->{retry} = 0;
73	}
74
75	sub _query {
76	my ($self, $query) = @_;
77
78	my $response;
79
80	if (!$self->{cache}->db_get($query, $response)) {
81	$response =~ s/^[^\x00]+\x00//;
82	return $response;
83	}
84
85	my $request = {
86	ready => (new Coro::Semaphore 0),
87	query => $query,
88	};
89
90	$self->{request}->put($request);
91	$request->{ready}->down;
92
93	$response = time . "\x00" . $request->{response};
94
95	$self->{cache}->db_put($query, $response);
96
97	$request->{response};
98	}
99
100	sub ip_query {
101	my ($self, $ip) = @_;
102	$self->_query($ip);
103	}
104
105	sub parse_ip_response {
106	my ($self, $response) = @_;
107	my %response;
108	while ($response =~ /^([^:]+):[ \t](.)$/mg) {
109	push @{$response{$1}}, $2;
110	}
111	\%response;
112	}
113
114	package Net::Whois::IP::whois;
115
116	# plain whois, as used by ripe and apnic
117
118	use base Net::Whois::IP::base;
119
120	sub _daemon {
121	my $self = shift;
122	while (my $request = $self->{request}->get) {
123	my $fh = new Coro::Socket PeerHost => $self->{server}
124	or $self->_failure, redo;
125
126	$fh->print("$request->{query}\012");
127	$fh->sysread($request->{response}, 16384);
128	length $request->{response}
129	or $self->_failure, redo;
130
131	$self->_ok;
132	$request->{ready}->up;
133	}
134	}
135
136	sub ip_query {
137	my ($self, $ip) = @_;
138	$self->SUPER::ip_query($ip);
139	}
140
141	sub parse_ip_response {
142	my ($self, $response) = @_;
143	$response =~ s/^%.*//mg;
144	$response =~ s/^\012+//;
145	$response =~ s/\012\012.*//s;
146	$self->SUPER::parse_ip_response($response);
147	}
148
149	package Net::Whois::IP::jpnic;
150
151	# totally different result format
152
153	use base Net::Whois::IP::whois;
154
155	sub ip_query {
156	my ($self, $ip) = @_;
157	$self->SUPER::ip_query("$ip/e");
158	}
159
160	sub parse_ip_response {
161	my ($self, $response) = @_;
162	$response =~ s/^\[\s.*//mg;
163	$response =~ s/^(?:\w\.\ )? \[ ([^\]]+) \] (.*) (?:\012(?=\s))?/$1: $2/mgx;
164	$self->SUPER::parse_ip_response($response);
165	}
166
167	package Net::Whois::IP::ripe;
168
169	# keepalive whois, as used by ripe and apnic
170
171	use base Net::Whois::IP::whois;
172
173	sub _daemon {
174	my $self = shift;
175	my $fh;
176
177	while (my $request = $self->{request}->get) {
178	unless ($self->{fh}) {
179	$fh = new Coro::Socket PeerHost => $self->{server};
180	$fh or $self->_failure, redo;
181	}
182
183	$fh->print("-k $request->{query}\012");
184	$request->{response} = $fh->readline("\012\012\012");
185	length $request->{response}
186	or $self->_failure, redo;
187
188	$self->_ok;
189	$request->{ready}->up;
190	}
191	}
192
193	package Net::Whois::IP::rwhois;
194
195	# rwhois 1.5
196
197	use base Net::Whois::IP::base;
198
199	sub _request {
200	my $self = shift;
201	my ($response, $error);
202
203	$self->{fh}->print("$_[0]\015\012");
204	while (defined (my $line = $self->{fh}->readline)) {
205	$line =~ s/[\015\012]+$/\n/g;
206	$response .= $line;
207	$line =~ /^%(ok\|error)/ and return $response;
208	}
209	return;
210	}
211
212	sub _daemon {
213	my $self = shift;
214	while (my $request = $self->{request}->get) {
215	unless ($self->{fh}) {
216	$self->{fh} = new Coro::Socket PeerHost => $self->{server};
217	$self->{fh} or $self->_failure, redo;
218	$self->{fh}->readline =~ /^%rwhois / or $self->_failure, redo;
219	$self->_request("-rwhois V-1.5 Net::Whois::IP") or $self->_failure, redo;
220	$self->_request("-forward off") or $self->_failure, redo;
221	$self->_request("-holdconnect on") or $self->_failure, redo;
222	}
223	$request->{response} = $self->_request($request->{query})
224	or $self->_failure, redo;
225	$request->{response} =~ s/^%error 330.*/%ok/m;
226	$self->_ok;
227	$request->{ready}->up;
228	}
229	}
230
231	sub ip_query {
232	my ($self, $ip) = @_;
233	$self->SUPER::ip_query("network $ip");
234	}
235
236	sub parse_ip_response {
237	my ($self, $response) = @_;
238	$response =~ s/^([^:]+):([^:]+):/$1-\L$2: /mg;
239	$response =~ s/^%.*//mg;
240	$response =~ s/\012\012.*//s;
241	$self->SUPER::parse_ip_response($response);
242	}
243
244	package Net::Whois::IP;
245
246	sub ip_range {
247	my $range = $_[0];
248
249	if ($range =~ /^
250	(2[0-5][0-9]\|1[0-9][0-9]\|[1-9][0-9]\|[0-9])
251	(?:\.
252	(2[0-5][0-9]\|1[0-9][0-9]\|[1-9][0-9]\|[0-9])
253	(?:\.
254	(2[0-5][0-9]\|1[0-9][0-9]\|[1-9][0-9]\|[0-9])
255	(?:\.
256	(2[0-5][0-9]\|1[0-9][0-9]\|[1-9][0-9]\|[0-9])
257	)?
258	)?
259	)?
260	\/
261	([0-9]+)
262	$/x) {
263	my $ip = inet_aton sprintf "%d.%d.%d.%d", $1, $2, $3, $4;
264	my $net = 1 << (31 - $5);
265	my $mask = inet_aton 2 ** 32 - $net;
266
267	my $ip1 = $ip & $mask;
268	my $ip2 = $ip1 \| inet_aton $net * 2 - 1;
269	return unpack "N2", "$ip1$ip2";
270	} elsif ($range =~ /^\s([0-9.]+)\s-\s([0-9.]+)\s$/) {
271	unpack "N2", pack "N2", $1, $2;
272	} else {
273	die "$range: unable to parse ip range";
274	}
275	}
276
277	# add a referral to a specific server
278	sub add_referral {
279	my ($netblock, $server) = @_;
280	my ($ip0, $ip1) = ip_range $netblock;
281	$db_referral->db_put((pack "N*", $ip1, $ip0) ^ "\x00\x00\x00\x00\xff\xff\xff\xff", "S" . $server->{name});
282	}
283
284	# get all referrals
285	sub parse_referral {
286	my ($query, $server) = @_;
287	my $referral = $arin->_query("referral $query");
288
289	while ($referral =~ /^referral:Referred-Auth-Area:([0-9.\/]+)$/mg) {
290	add_referral $1, $server;
291	}
292	}
293
294	sub init(;%) {
295	my (%arg) = @_;
296	$arg{db_home} or $arg{db_env} or Carp::croak "either db_home or db_env home must be set";
297	$db_env = $arg{db_env} \|\| do {
298	mkdir $arg{db_home}, 0700;
299
300	$db_env = new BerkeleyDB::Env
301	-Home => $arg{db_home},
302	-Cachesize => $arg{db_cachesize} \|\| 1_000_000,
303	-ErrFile => $arg{db_errfile} \|\| "/dev/fd/2",
304	-ErrPrefix => "NET-WHOIS-IP",
305	-Verbose => 1,
306	-Flags => DB_CREATE\|DB_RECOVER\|DB_INIT_MPOOL\|DB_INIT_TXN
307	or die "$arg{db_home}: unable to create database home";
308	};
309
310	$arin = new Net::Whois::IP::rwhois "ARIN", server => "rwhois.arin.net:rwhois(4321)";
311
312	$ripe = new Net::Whois::IP::ripe "RIPE", server => "whois.ripe.net:whois(43)";
313	$lacnic = new Net::Whois::IP::whois "LACNIC", server => "whois.lacnic.net:whois(43)";
314	$brnic = new Net::Whois::IP::whois "BRNIC", server => "whois.registro.br:whois(43)";
315	$apnic = new Net::Whois::IP::ripe "APNIC", server => "whois.apnic.net:whois(43)";
316	$jpnic = new Net::Whois::IP::jpnic "JPNIC", server => "whois.nic.ad.jp:whois(43)";
317
318	$db_referral = new_btree "referral";
319
320	add_referral "129.13.0.0/16", $ripe;
321	add_referral "200.0.0.0/8", $lacnic;
322	add_referral "200.128.0.0/9", $brnic;
323
324	parse_referral "32.0.0.0", $ripe;
325	parse_referral "202.0.0.0", $apnic;
326	parse_referral "192.50.0.0", $apnic;
327
328	add_referral "133.0.0.0/8", $jpnic;
329	}
330
331	###
332
333	init db_home => "/tmp/whois";
334
335	sub ip_query {
336	my $ip = shift;
337
338	print "Q?$ip ";
339
340	my $server = $arin;
341
342	my $c = $db_referral->db_cursor;
343
344	my ($k, $v) = (inet_aton $ip);
345	if (!$c->c_get($k, $v, DB_SET_RANGE)) {
346	my ($ip1, $ip0) = unpack "N*", $k ^ "\x00\x00\x00\x00\xff\xff\xff\xff";
347	my $ipn = unpack "N", inet_aton $ip;
348
349	if ($ip0 <= $ipn && $ipn <= $ip1) {
350	if ($v =~ s/^S//) {
351	$server = $server{$v} if $server{$v};
352	} elsif ($v =~ s/^I//) {
353	die;
354	} else {
355	# database corrupted or newer
356	}
357	}
358	}
359
360	print "($ip,$server->{name})\n";
361	$server->parse_ip_response($server->ip_query($ip));
362	}
363
364	for (qw(132.64.0.0 129.13.162.91 193.166.90.111 213.189.83.103 161.142.8.76 66.68.103.189 200.149.85.112 210.49.200.207 133.11.128.254)) {
365	use PApp::Util;
366	warn PApp::Util::dumpval ip_query($_);
367	}
368
369	exit;
370
371	__END__
372
373	1;
374
375	=back
376
377	=head1 AUTHOR
378
379	Marc Lehmann <pcg@goof.com>
380	http://www.goof.com/pcg/marc/
381
382	=cut
383