[ViewVC] Diff of: cvs/Net-Whois-IP/IP.pm

Comparing Net-Whois-IP/IP.pm (file contents):
Revision 1.2 by root, Sat Nov 30 02:45:47 2002 UTC vs.
Revision 1.3 by root, Sun Dec 1 14:51:23 2002 UTC

…		…
9	=head1 DESCRIPTION	9	=head1 DESCRIPTION
10		10
11	=over 4	11	=over 4
12		12
13	=cut	13	=cut
14
15	# http://www.irr.net/docs/rpsl.html
16		14
17	package Net::Whois::IP;	15	package Net::Whois::IP;
18		16
19	BEGIN {	17	BEGIN {
20	$VERSION = 0.01;	18	$VERSION = 0.01;
…		…
44	-Env => $db_env,	42	-Env => $db_env,
45	-Filename => $_[0],	43	-Filename => $_[0],
46	-Flags => DB_CREATE,	44	-Flags => DB_CREATE,
47	or die "$_[0]: unable to create/open table";	45	or die "$_[0]: unable to create/open table";
48	}	46	}
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		47
246	sub ip_range {	48	sub ip_range {
247	my $range = $_[0];	49	my $range = $_[0];
248		50
249	if ($range =~ /^	51	if ($range =~ /^
…		…
266		68
267	my $ip1 = $ip & $mask;	69	my $ip1 = $ip & $mask;
268	my $ip2 = $ip1 \| inet_aton $net * 2 - 1;	70	my $ip2 = $ip1 \| inet_aton $net * 2 - 1;
269	return unpack "N2", "$ip1$ip2";	71	return unpack "N2", "$ip1$ip2";
270	} elsif ($range =~ /^\s([0-9.]+)\s-\s([0-9.]+)\s$/) {	72	} elsif ($range =~ /^\s([0-9.]+)\s-\s([0-9.]+)\s$/) {
271	unpack "N2", pack "N2", $1, $2;	73	unpack "N*", (inet_aton $1) . (inet_aton $2);
272	} else {	74	} else {
273	die "$range: unable to parse ip range";	75	die "$range: unable to parse ip range";
274	}	76	}
275	}	77	}
		78
		79	package Net::Whois::IP::base;
		80
		81	sub new {
		82	my $class = shift;
		83	my $self = bless {
		84	name => @_,
		85	}, $class;
		86	$self->{request} \|\|= new Coro::Channel $self->{request_backlog} \|\| 10;
		87	$self->{daemon} = Coro::async {
		88	while () {
		89	eval { $self->_daemon };
		90	warn "restarting daemon for whois server $self->{name}: $@";
		91	}
		92	};
		93	$self->{daemon}->prio(1);
		94	$self->{cache} = Net::Whois::IP::new_btree "whois_" . lc $self->{name};
		95	$server{$self->{name}} = $self;
		96	}
		97
		98	sub _failure {
		99	my ($self, $min) = shift;
		100	undef $self->{fh};
		101	$self->{retry} = $min if $self->{retry} < $min;
		102	Coro::Timer::sleep 1.5 ** $self->{retry} - 2 if $self->{retry};
		103	$self->{retry}++ if $self->{retry} < 17;
		104	}
		105
		106	sub _ok {
		107	my $self = shift;
		108	$self->{retry} = 0;
		109	}
		110
		111	sub _query {
		112	my ($self, $query) = @_;
		113
		114	my $response;
		115
		116	if (!$self->{cache}->db_get($query, $response)) {
		117	$response =~ s/^[^\x00]+\x00//;
		118	return $response;
		119	}
		120
		121	my $request = {
		122	ready => (new Coro::Semaphore 0),
		123	query => $query,
		124	};
		125
		126	$self->{request}->put($request);
		127	$request->{ready}->down;
		128
		129	$request->{response} =~ s/\015//g;
		130	$request->{response} =~ s/\012/\n/g if "\012" ne "\n";
		131
		132	$response = time . "\x00" . $request->{response};
		133
		134	$self->{cache}->db_put($query, $response);
		135
		136	$request->{response};
		137	}
		138
		139	sub ip_query {
		140	my ($self, $ip) = @_;
		141	$self->sanitize_ip_response($self->_query($ip));
		142	}
		143
		144	sub sanitize_ip_response {
		145	my ($self, $response) = @_;
		146	$response;
		147	}
		148
		149	sub parse_ip_response {
		150	my ($self, $response, $tags, $res) = @_;
		151	$res->{whois_server} = $self->{name};
		152	while ($response =~ /^([^:]+):[ \t]*
		153	(
		154	.*
		155	(?:\n[\t ].)
		156	)
		157	/mgx) {
		158	my ($tag, $val) = ($1, $2);
		159	if (exists $tags->{$tag}) {
		160	push @{$res->{$tags->{$tag}}}, $val if defined $tags->{$tag};
		161	} else {
		162	use Carp;
		163	confess "unknown tag $tag=$val";
		164	}
		165	}
		166	$res;
		167	}
		168
		169	# check wether the given response is a referral to another server
		170	# find out which one, and the ip range we were referred
		171	sub is_ip_referral {
		172	my ($self, $response) = @_;
		173	# ($iprange, $server)
		174	();
		175	}
		176
		177	package Net::Whois::IP::whois;
		178
		179	# plain whois, as used by ripe and apnic
		180
		181	use base Net::Whois::IP::base;
		182
		183	sub _daemon {
		184	my $self = shift;
		185	my $request;
		186	while ($request = $self->{request}->get) {
		187	my $fh = new Coro::Socket PeerHost => $self->{server}
		188	or $self->_failure, redo;
		189
		190	$fh->print("$request->{query}\012");
		191	$fh->sysread($request->{response}, 16384);
		192
		193	length $request->{response} or $self->_failure, redo;
		194	$request->{response} =~ /^% query rate limit exceeded/im and $self->_failure(9), redo;
		195
		196	$self->_ok;
		197	$request->{ready}->up;
		198	}
		199	}
		200
		201	sub sanitize_ip_response {
		202	my ($self, $response) = @_;
		203	$response = "" if $response =~ /^% not assigned/im;
		204	$response =~ s/^%.*//mg;
		205	$response =~ s/[ \t]+$//mg; # brnic, maybe others
		206	$response =~ s/^\n+//;
		207	$response =~ s/\n\n.*//s;
		208	$self->SUPER::sanitize_ip_response($response);
		209	}
		210
		211	sub parse_ip_response {
		212	my ($self, $response, $tags) = @_;
		213	$self->SUPER::parse_ip_response($response, $tags \|\| {
		214	inetnum => "netblock",
		215	netname => "netname",
		216	descr => "description",
		217	owner => "description",
		218	address => "description",
		219	phone => "description",
		220	country => "country",
		221	ownerid => "owner-c",
		222	"admin-c" => "admin-c",
		223	"tech-c" => "tech-c",
		224	"owner-c" => "owner-c",
		225	"abuse-c" => "abuse-c",
		226	status => "status",
		227	notify => "notify",
		228	changed => "changed",
		229	created => "created",
		230	source => "source",
		231	remarks => "remarks",
		232	"mnt-by" => "mnt-by",
		233	"mnt-irt" => "irt-c", # incident response team
		234	"rev-srv" => "nameserver",
		235	nserver => "nameserver",
		236	"mnt-lower" => undef,
		237	"mnt-routes"=> undef,
		238	responsible => undef,
		239	nsstat => undef,
		240	nslastaa => undef,
		241	"aut-num" => undef,
		242	inetrev => undef, # nameserver-dependent
		243	"inetnum-up" => undef,
		244	});
		245	}
		246
		247	sub is_ip_referral {
		248	my ($self, $response) = @_;
		249	$response =~ /^inetnum:\s+(.*)/m
		250	or return;
		251	my $iprange = $1;
		252	if ($response =~ /^remarks:\s+These addresses have been further assigned to Brazilian users./m) {
		253	return ($iprange, $server{BRNIC});
		254	}
		255	# ($iprange, $server)
		256	();
		257	}
		258
		259	package Net::Whois::IP::jpnic;
		260
		261	# totally different result format
		262
		263	use base Net::Whois::IP::whois;
		264
		265	sub ip_query {
		266	my ($self, $ip) = @_;
		267	$self->SUPER::ip_query("$ip/e");
		268	}
		269
		270	sub sanitize_ip_response {
		271	my ($self, $response) = @_;
		272	$response =~ s/^\[\s.*//mg;
		273	$response =~ s/^(?:\w\.\ )? \[ ([^\]]+) \] (.*)/$1: $2/mgx;
		274	$self->SUPER::sanitize_ip_response($response);
		275	}
		276
		277	sub parse_ip_response {
		278	my ($self, $response) = @_;
		279	$self->SUPER::parse_ip_response($response, {
		280	"Network Information" => undef,
		281	"Network Number" => "netblock",
		282	"Network Name" => "netname",
		283	"Organization" => "description",
		284	"Administrative Contact" => "admin-c",
		285	"Technical Contact" => "tech-c",
		286	"Nameserver" => "nameserver",
		287	"Reply Mail" => undef,
		288	"Assigned Date" => "created",
		289	"Return Date" => "expires",
		290	"Last Update" => "changed",
		291	}, {
		292	country => "JP",
		293	});
		294	}
		295
		296	package Net::Whois::IP::ripe;
		297
		298	# keepalive whois, as used by ripe and apnic
		299
		300	use base Net::Whois::IP::whois;
		301
		302	sub _daemon {
		303	my $self = shift;
		304	my $fh;
		305
		306	my $request;
		307	while ($request = $self->{request}->get) {
		308	unless ($self->{fh}) {
		309	$fh = new Coro::Socket PeerHost => $self->{server};
		310	$fh or $self->_failure, redo;
		311	}
		312
		313	$fh->print("-k $request->{query}\012");
		314	$request->{response} = $fh->readline("\012\012\012");
		315	length $request->{response}
		316	or $self->_failure, redo;
		317
		318	$self->_ok;
		319	$request->{ready}->up;
		320	}
		321	}
		322
		323	sub sanitize_ip_response {
		324	my ($self, $response) = @_;
		325	$response = "" if $response =~ /^netname:\s+IANA-BLK$/m;
		326	$response = "" if $response =~ /This network range is not allocated to APNIC./;
		327	# $response = "" if $response =~ /^remarks:\s+.*the IP has not been allocated by APNIC./m;
		328	$self->SUPER::sanitize_ip_response($response);
		329	}
		330
		331	package Net::Whois::IP::rwhois;
		332
		333	# rwhois 1.5, of course, as usual arin's implementation is utterly broken
		334	# and doesn't help very much
		335
		336	use base Net::Whois::IP::base;
		337
		338	sub _request {
		339	my $self = shift;
		340	my ($response, $error);
		341
		342	$self->{fh}->print("$_[0]\015\012");
		343	while (defined (my $line = $self->{fh}->readline)) {
		344	$line =~ s/[\015\012]+$/\012/g;
		345	$response .= $line;
		346	$line =~ /^%(ok\|error)/ and return $response;
		347	}
		348	return;
		349	}
		350
		351	sub _daemon {
		352	my $self = shift;
		353	my $request;
		354	while ($request = $self->{request}->get) {
		355	unless ($self->{fh}) {
		356	$self->{fh} = new Coro::Socket PeerHost => $self->{server};
		357	$self->{fh} or $self->_failure, redo;
		358	$self->{fh}->readline =~ /^%rwhois / or $self->_failure, redo;
		359	$self->_request("-rwhois V-1.5 Net::Whois::IP") or $self->_failure, redo;
		360	$self->_request("-forward off") or $self->_failure, redo;
		361	$self->_request("-holdconnect on") or $self->_failure, redo;
		362	}
		363	$request->{response} = $self->_request($request->{query})
		364	or $self->_failure, redo;
		365	$request->{response} =~ s/^%error 330.*/%ok/m;
		366	$self->_ok;
		367	$request->{ready}->up;
		368	}
		369	}
		370
		371	sub ip_query {
		372	my ($self, $ip) = @_;
		373	$self->SUPER::ip_query("network $ip");
		374	}
		375
		376	sub sanitize_ip_response {
		377	my ($self, $response) = @_;
		378	$response =~ s/^% referral/REFERRAL:/mg;
		379	$response =~ s/^%.*//mg;
		380	$response =~ s/\n\n.*//s;
		381	$response = "" if $response =~ /^network:Org-Name:Various Registries $Maintained by ARIN$/m;
		382	$response =~ s/^([^:]+):([^:]+):/$1-\L$2: /mg;
		383	$response;
		384	}
		385
		386	sub parse_ip_response {
		387	my ($self, $response) = @_;
		388	$self->SUPER::parse_ip_response($response, {
		389	"network-class-name" => undef,
		390	"network-auth-area" => "auth-area",
		391	"network-id" => "id",
		392	"network-handle" => "handle",
		393	"network-network-name" => "netname",
		394	"network-ip-network" => undef,
		395	"network-ip-network-block" => "netblock",
		396	"network-org-name" => "description",
		397	"network-street-address" => "address",
		398	"network-city" => "address",
		399	"network-state" => "address",
		400	"network-postal-code" => "address",
		401	"network-country-code" => "country",
		402	"network-tech-contact;i" => "tech-c",
		403	"network-admin-contact;i" => "admin-c",
		404	"network-created" => "created",
		405	"network-updated" => "changed",
		406	});
		407	}
		408
		409	sub is_ip_referral {
		410	my ($self, $response) = @_;
		411	$response =~ /^network-ip-network-block:(.*)$/m
		412	or return ();
		413	my $iprange = $1;
		414	if ($response =~ /^REFERRAL: rwhois:\/\/([^\/]+)/m) {
		415	my $server = $1;
		416	if ($server =~ /^whois.ripe.net/) {
		417	return ($iprange, $server{RIPE});
		418	} elsif ($server =~ /^rwhois.nic.ad.jp/) {
		419	return ($iprange, $server{JPNIC});
		420	} elsif ($server =~ /^r?whois.apnic.net/) {
		421	return ($iprange, $server{APNIC});
		422	} elsif ($server =~ /^rwhois.lacnic.net/) {
		423	return ($iprange, $server{LACNIC}); # not yet seen, hope it will be implemented like this
		424	} elsif ($server =~ /^rwhois.internex.net/) {
		425	# alive(!)
		426	return ();
		427	} elsif ($server =~ /^rwhois.nstar.net/) {
		428	return ();
		429	} elsif ($server =~ /^rwhois.sesqui.net/) {
		430	return ();
		431	} elsif ($server =~ /^nic.ddn.mil/) {
		432	# whois.nic.mil (the actual address) only supports the antique
		433	# nonparsable arin whois format
		434	return ();
		435	} else {
		436	die "$response\nreferral to whois server $server";
		437	}
		438	die "$server $iprange";
		439	} elsif ($response =~ /^network-org-name: Latin American and Caribbean IP address Regional Registry/m) {
		440	return ($iprange, $server{LACNIC});
		441	} elsif ($response =~ /^network-org-name: Asia Pacific Network Information Centre/m) {
		442	return ($iprange, $server{APNIC});
		443	} elsif ($response =~ /^network-org-name: RIPE Network Coordination Centre/m) {
		444	return ($iprange, $server{RIPE});
		445	}
		446	();
		447	}
		448
		449	package Net::Whois::IP;
276		450
277	# add a referral to a specific server	451	# add a referral to a specific server
278	sub add_referral {	452	sub add_referral {
279	my ($netblock, $server) = @_;	453	my ($netblock, $server) = @_;
280	my ($ip0, $ip1) = ip_range $netblock;	454	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});	455	$db_referral->db_put(
		456	(pack "N*", $ip1, $ip0) ^ "\x00\x00\x00\x00\xff\xff\xff\xff",
		457	$server->{name},
		458	);
282	}	459	}
283		460
284	# get all referrals	461	# get all referrals
285	sub parse_referral {	462	sub parse_referral {
286	my ($query, $server) = @_;	463	my ($query, $server) = @_;
…		…
288		465
289	while ($referral =~ /^referral:Referred-Auth-Area:([0-9.\/]+)$/mg) {	466	while ($referral =~ /^referral:Referred-Auth-Area:([0-9.\/]+)$/mg) {
290	add_referral $1, $server;	467	add_referral $1, $server;
291	}	468	}
292	}	469	}
		470
		471	=item init db_home => $path, ...
		472
		473	Initializes the module.
		474
		475	This function must be called before calling any of the other functions,
		476	and the only required agrument is C<db_home>, the path where the module
		477	will store it's cache (will be created if neccessary).
		478
		479	Other Arguments:
		480
		481	db_home database home directory
		482	db_env the database env (should be created by the module itself)
		483	db_errfile the file wheer the database will output and errors (/dev/fd/2)
		484	db_cachesize size of the in-memory cache (1_000_000)
		485
		486	=cut
293		487
294	sub init(;%) {	488	sub init(;%) {
295	my (%arg) = @_;	489	my (%arg) = @_;
296	$arg{db_home} or $arg{db_env} or Carp::croak "either db_home or db_env home must be set";	490	$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 {	491	$db_env = $arg{db_env} \|\| do {
…		…
301	-Home => $arg{db_home},	495	-Home => $arg{db_home},
302	-Cachesize => $arg{db_cachesize} \|\| 1_000_000,	496	-Cachesize => $arg{db_cachesize} \|\| 1_000_000,
303	-ErrFile => $arg{db_errfile} \|\| "/dev/fd/2",	497	-ErrFile => $arg{db_errfile} \|\| "/dev/fd/2",
304	-ErrPrefix => "NET-WHOIS-IP",	498	-ErrPrefix => "NET-WHOIS-IP",
305	-Verbose => 1,	499	-Verbose => 1,
306	-Flags => DB_CREATE\|DB_RECOVER\|DB_INIT_MPOOL\|DB_INIT_TXN	500	-Flags => DB_CREATE\|DB_RECOVER_FATAL\|DB_INIT_MPOOL\|DB_INIT_TXN
307	or die "$arg{db_home}: unable to create database home";	501	or die "$arg{db_home}: unable to create database home";
308	};	502	};
309		503
310	$arin = new Net::Whois::IP::rwhois "ARIN", server => "rwhois.arin.net:rwhois(4321)";	504	$arin = new Net::Whois::IP::rwhois "ARIN", server => "rwhois.arin.net:rwhois(4321)";
311		505
…		…
315	$apnic = new Net::Whois::IP::ripe "APNIC", server => "whois.apnic.net:whois(43)";	509	$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)";	510	$jpnic = new Net::Whois::IP::jpnic "JPNIC", server => "whois.nic.ad.jp:whois(43)";
317		511
318	$db_referral = new_btree "referral";	512	$db_referral = new_btree "referral";
319		513
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;	514	parse_referral "32.0.0.0", $ripe;
325	parse_referral "202.0.0.0", $apnic;	515	parse_referral "202.0.0.0", $apnic;
326	parse_referral "192.50.0.0", $apnic;	516	parse_referral "192.50.0.0", $apnic;
327		517
		518	add_referral "129.13.0.0/16", $ripe;
328	add_referral "133.0.0.0/8", $jpnic;	519	add_referral "133.0.0.0/8", $jpnic;
		520	add_referral "200.0.0.0/8", $lacnic;
		521	add_referral "200.128.0.0/9", $brnic;
329	}	522	}
330		523
331	###	524	=item ip_query $ip
332		525
333	init db_home => "/tmp/whois";	526	Queries the whois server for the given ip address (which must be something
		527	inet_aton understands).
		528
		529	The return value currently is a hash, which looks slightly difefrent for
		530	different registries, see examples.
		531
		532	=cut
334		533
335	sub ip_query {	534	sub ip_query {
336	my $ip = shift;	535	my $ip = shift;
337		536
338	print "Q?$ip ";
339
340	my $server = $arin;	537	my $server = $arin;
341		538
		539	my ($prev_response, $prev_server);
		540
		541	referral:
342	my $c = $db_referral->db_cursor;	542	my $c = $db_referral->db_cursor;
343		543
		544	# iterate over all possibly matching referral ranges
		545	# and choose the one that fits tightest
344	my ($k, $v) = (inet_aton $ip);	546	my ($k, $v) = (inet_aton $ip);
345	if (!$c->c_get($k, $v, DB_SET_RANGE)) {	547	if (!$c->c_get($k, $v, DB_SET_RANGE)) {
		548	find: {
		549	do {
346	my ($ip1, $ip0) = unpack "N*", $k ^ "\x00\x00\x00\x00\xff\xff\xff\xff";	550	my ($ip1, $ip0) = unpack "N*", $k ^ "\x00\x00\x00\x00\xff\xff\xff\xff";
347	my $ipn = unpack "N", inet_aton $ip;	551	my $ipn = unpack "N", inet_aton $ip;
		552	0 && printf "Q=%15s < %15s < %15s, $v\n",
		553	(inet_ntoa pack "N", $ip0),
		554	(inet_ntoa pack "N", $ipn),
		555	(inet_ntoa pack "N", $ip1);
348		556
349	if ($ip0 <= $ipn && $ipn <= $ip1) {	557	if ($ipn <= $ip1) {
350	if ($v =~ s/^S//) {	558	if ($ip0 <= $ipn) {
		559	my ($name, $rip) = split /\t/, $v;
351	$server = $server{$v} if $server{$v};	560	$server = $server{$name} if $server{$name};
352	} elsif ($v =~ s/^I//) {	561	$ip = $ip if $rip;
		562	last;
353	die;	563	}
354	} else {	564	} else {
355	# database corrupted or newer	565	last;
356	}	566	}
		567	} while !$c->c_get($k, $v, DB_NEXT);
357	}	568	}
358	}	569	}
359		570
360	print "($ip,$server->{name})\n";	571	my $response = $server->ip_query($ip);
361	$server->parse_ip_response($server->ip_query($ip));	572	if ($response) {
362	}	573	if (my ($iprange, $refer) = $server->is_ip_referral($response)) {
		574	($prev_server, $prev_response) = ($server, $response);
		575	$server = $refer;
		576	add_referral $iprange, $server;
		577	goto referral;
		578	}
		579	} else {
		580	($server, $response) = ($prev_server, $prev_response);
		581	}
363		582
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)) {	583	if (!$response) {
365	use PApp::Util;	584	($server, $response) = ($arin, $arin->ip_query($ip));
366	warn PApp::Util::dumpval ip_query($_);	585	}
367	}	586
		587	my $res = $server->parse_ip_response($response);
		588	for my $range (@{$res->{netblock} \|\| []}) {
		589	if (my ($ip0, $ip1) = eval { ip_range $range }) {
		590	# limit to /24
		591	my $ipn = unpack "N", inet_aton $ip;
		592	$ip0 = $ipn & 0xffffff00 if $ip0 < ($ipn & 0xffffff00);
		593	$ip1 = ($ipn + 256 & 0xffffff00) - 1 if $ip1 > ($ipn + 256 & 0xffffff00);
		594	$db_referral->db_put(
		595	(pack "N*", $ip1, $ip0) ^ "\x00\x00\x00\x00\xff\xff\xff\xff",
		596	"$server->{name}\t$ip",
		597	);
		598	}
		599	}
368		600
369	exit;	601	$db_env->txn_checkpoint(10,1,0);
370		602
371	__END__	603	$res;
		604	}
372		605
373	1;	606	1;
		607
		608	=back
		609
		610	=head2 WHOIS EXAMPLES
		611
		612	=over 4
		613
		614	=item RIPE
		615
		616	ip_query "129.13.162.91" =>
		617	(
		618	source => [ "RIPE" ],
		619	"mnt-by" => [ "DFN-NTFY" ],
		620	country => [ "DE" ],
		621	netname => [ "KLICK" ],
		622	status => [ "ASSIGNED PI" ],
		623	description => [ "Karlsruher Lichtleiter Kommunikationsnetz",
		624	"University of Karlsruhe",
		625	"Germany" ],
		626	nameserver => [ "netserv.rz.uni-karlsruhe.de",
		627	"iraun1.ira.uka.de",
		628	"deneb.dfn.de",
		629	"ns.germany.eu.net" ],
		630	"tech-c" => [ "HUK2-RIPE" ],
		631	changed => [ "lortz\@rz.uni-karlsruhe.de 19910212",
		632	"nipper\@ira.uka.de 19920422",
		633	"nipper\@xlink.net 19930513",
		634	"rv\@Informatik.Uni-Dortmund.DE 19931129",
		635	"poldi\@dfn.de 19940309",
		636	"dolderer\@nic.de 19940930",
		637	"dolderer\@nic.de 19970821",
		638	"schweikh\@noc 19990819" ],
		639	netblock => [ "129.13.0.0 - 129.13.255.255" ],
		640	"admin-c" => [ "BL118" ],
		641	notify => [ "guardian\@nic.de" ],
		642	whois_server => "RIPE"
		643	)
		644
		645	=item LACNIC
		646
		647	ip_query "200.5.0.0" =>
		648	(
		649	source => [ "ARIN-LACNIC-TRANSITION" ],
		650	created => [ 19960205 ],
		651	country => [ "PR" ],
		652	changed => [ 19960205 ],
		653	"owner-c" => [ "PR-PRMS-LACNIC",
		654	"RS564-ARIN" ],
		655	netblock => [ "200.5.0/21" ],
		656	status => [ "assigned" ],
		657	description => [ "Puerto Rico Medical Services Administration",
		658	"Management Information Systems Department",
		659	"PO Box 2129",
		660	"San Juan, PR 00922-2129",
		661	"PR" ],
		662	whois_server => "LACNIC"
		663	)
		664
		665	=item BRNIC
		666
		667	ip_query "200.128.0.0" =>
		668	(
		669	created => [ 20000215 ],
		670	"tech-c" => [ "ALG149" ],
		671	changed => [ 20001017 ],
		672	"owner-c" => [ "003.508.097/0001-36",
		673	"ALG149" ],
		674	netblock => [ "200.128/16" ],
		675	"abuse-c" => [ "SIC128" ],
		676	description => [ "Associa\347\343o Rede Nacional de Ensino e Pesquisa",
		677	"Estrada Dona Castorina, 110, 353",
		678	"22460-320 - Rio de Janeiro - RJ",
		679	"(021) 274-7445 []" ],
		680	whois_server => "BRNIC",
		681	nameserver => [ "NS.POP-BA.RNP.BR",
		682	"SERVER1.POP-DF.RNP.BR",
		683	"SERVER1.AGR.UFBA.BR",
		684	"DNS.UFBA.BR" ]
		685	)
		686
		687	=item JPNIC
		688
		689	ip_query "133.11.128.254" =>
		690	(
		691	created => [ "" ],
		692	"tech-c" => [ "AK003JP",
		693	"MN010JP" ],
		694	netname => [ "UTSNET" ],
		695	changed => [ "2002/10/15 13:06:48 (JST)\n kato\@wide.ad.jp" ],
		696	netblock => [ "133.11.0.0" ],
		697	"admin-c" => [ "MN010JP" ],
		698	description => [ "University of Tokyo" ],
		699	whois_server => "JPNIC",
		700	expires => [ "" ],
		701	nameserver => [ "dns1.nc.u-tokyo.ac.jp",
		702	"dns2.nc.u-tokyo.ac.jp",
		703	"dns3.nc.u-tokyo.ac.jp",
		704	"ns.nc.u-tokyo.ac.jp",
		705	"ns.s.u-tokyo.ac.jp" ]
		706	)
		707
		708	=item APNIC
		709
		710	ip_query "203.2.75.99" =>
		711	(
		712	source => [ "APNIC" ],
		713	"mnt-by" => [ "APNIC-HM" ],
		714	"tech-c" => [ "TN38-AP" ],
		715	country => [ "AU" ],
		716	netname => [ "OPTUSINTERNET-AU" ],
		717	changed => [ "nobody\@aunic.net 20010524",
		718	"aunic-transfer\@apnic.net 20010525",
		719	"hostmaster\@apnic.net 20011004" ],
		720	netblock => [ "203.2.75.0 - 203.2.75.255" ],
		721	status => [ "ALLOCATED PORTABLE" ],
		722	"admin-c" => [ "TN38-AP" ],
		723	description => [ "OPTUS INTERNET - RETAIL",
		724	"INTERNET SERVICES",
		725	"St Leonards, NSW" ],
		726	whois_server => "APNIC"
		727	)
		728
		729	=item ARIN
		730
		731	ip_query "68.52.164.8" =>
		732	(
		733	country => [ "US" ],
		734	netname => [ "JUMPSTART-DC-5" ],
		735	"auth-area" => [ "0.0.0.0/0" ],
		736	description => [ "Comcast Cable Communications, Inc." ],
		737	created => [ "20200718050000000" ],
		738	"tech-c" => [ "FG200-ARIN.0.0.0.0/0" ],
		739	changed => [ "19200307050000000" ],
		740	handle => [ "NET-68-52-160-0-1" ],
		741	netblock => [ "68.52.160.0 - 68.52.175.255" ],
		742	id => [ "NET-68-52-160-0-1.0.0.0.0/0" ],
		743	address => [ "3 Executive Campus Cherry Hill",
		744	"NJ",
		745	"08002" ],
		746	whois_server => "ARIN"
		747	)
374		748
375	=back	749	=back
376		750
377	=head1 AUTHOR	751	=head1 AUTHOR
378		752

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing Net-Whois-IP/IP.pm (file contents): Revision 1.2 by root, Sat Nov 30 02:45:47 2002 UTC vs. Revision 1.3 by root, Sun Dec 1 14:51:23 2002 UTC

Diff Legend

Comparing Net-Whois-IP/IP.pm (file contents):
Revision 1.2 by root, Sat Nov 30 02:45:47 2002 UTC vs.
Revision 1.3 by root, Sun Dec 1 14:51:23 2002 UTC