cvsroot/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 (23 years, 10 months ago) by root
Branch:	MAIN
Changes since 1.1:	+347 -2 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.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	root	1.2	# http://www.irr.net/docs/rpsl.html
16
17	root	1.1	package Net::Whois::IP;
18
19			BEGIN {
20			$VERSION = 0.01;
21			@EXPORT_OK = qw();
22			}
23
24			use base Exporter;
25
26	root	1.2	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	root	1.1
371	root	1.2	__END__
372	root	1.1
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