package IP::Authority;
use strict;
use warnings;
use Socket qw ( inet_aton );
use vars qw ( $VERSION );
$VERSION = '1305.001'; # MAY 2013, version 0.01
my $singleton = undef;
my $ip_db;
my $null = substr(pack('N',0),0,1);
my $nullnullnull = $null . $null . $null;
my %auth;
my $ip_match = qr/^(\d|[01]?\d\d|2[0-4]\d|25[0-5])\.(\d|[01]?\d\d|2[0-4]\d|25[0-5])\.(\d|[01]?\d\d|2[0-4]\d|25[0-5])\.(\d|[01]?\d\d|2[0-4]\d|25[0-5])$/o;
my $bit0;
my $bit1;
my @mask;
my @dtoc;
{
$bit0 = substr(pack('N',2 ** 31),0,1);
$bit1 = substr(pack('N',2 ** 30),0,1);
for (my $i = 0; $i <= 31; $i++){
$mask[$i] = pack('N',2 ** (31 - $i));
}
for (my $i = 0; $i <= 255; $i++){
$dtoc[$i] = substr(pack('N',$i),3,1);
}
(my $module_dir = __FILE__) =~ s/\.pm$//;
local $/; # set it so <> reads all the file at once
open (AUTH, "< $module_dir/auth.gif")
or die ("couldn't read authority database: $!");
binmode AUTH;
my $auth_ultra = <AUTH>; # read in the file
close AUTH;
my $auth_num = (length $auth_ultra) / 3;
for (my $i = 0; $i < $auth_num; $i++){
my $auth = substr($auth_ultra,3 * $i + 1,2);
$auth = undef if ($auth eq '--');
$auth{substr($auth_ultra,3 * $i,1)} = $auth;
}
open (IP, "< $module_dir/ipauth.gif")
or die ("couldn't read IP database: $!");
binmode IP;
$ip_db = <IP>;
close IP;
}
sub new ()
{
my $caller = shift;
unless (defined $singleton){
my $class = ref($caller) || $caller;
$singleton = bless {}, $class;
}
return $singleton;
}
sub inet_atoauth
{
my $inet_a = $_[1];
if ($inet_a =~ $ip_match){
return inet_ntoauth($dtoc[$1].$dtoc[$2].$dtoc[$3].$dtoc[$4]);
} else {
if (defined (my $n = inet_aton($inet_a))){
return inet_ntoauth($n);
} else {
return undef;
}
}
}
sub db_time
{
return unpack("N",substr($ip_db,0,4));
}
sub inet_ntoauth
{
my $inet_n = $_[1] || $_[0];
my $pos = 4;
my $byte_zero = substr($ip_db,$pos,1);
# loop through bits of IP address
for (my $i = 0; $i <= 31; $i++){
if (($inet_n & $mask[$i]) eq $mask[$i]){
# bit[$i] is set [binary one]
# - jump to next node
# (start of child[1] node)
if (($byte_zero & $bit1) eq $bit1){
$pos = $pos + 1 + unpack('N', $nullnullnull . ($byte_zero ^ $bit1));
} else {
$pos = $pos + 3 + unpack('N', $null . substr($ip_db,$pos,3));
}
} else {
# bit[$i] is unset [binary zero]
# jump to end of this node
# (start of child[0] node)
if (($byte_zero & $bit1) eq $bit1){
$pos = $pos + 1;
} else {
$pos = $pos + 3;
}
}
# all terminal nodes of the tree start with zeroth bit
# set to zero. the first bit can then be used to indicate
# whether we're using the first or second byte to store the
# country code
$byte_zero = substr($ip_db,$pos,1);
if (($byte_zero & $bit0) eq $bit0){ # country code
if (($byte_zero & $bit1) eq $bit1){
# unpopular country code - stored in second byte
return $auth{substr($ip_db,$pos+1,1)};
} else {
# popular country code - stored in bits 2-7
# (we already know that bit 1 is not set, so
# just need to unset bit 1)
return $auth{$byte_zero ^ $bit0};
}
}
}
}
1;
__END__
=head1 NAME
IP::Authority - fast lookup of authority by IP address
=head1 SYNOPSIS
use IP::Authority;
my $reg = IP::Authority->new();
print $reg->inet_atoauth('212.67.197.128') ."\n";
print $reg->inet_atoauth('www.slashdot.org') ."\n";
=head1 DESCRIPTION
Historically, the former InterNIC managed (under the auspices of IANA)
the allocation of IP numbers to ISPs and other organizations. This changed
somewhat when the Regional Internet Registry system was started, with the
creation of three (and later, four) Regional Internet Registries (RIRs)
around the world, each managing the allocation of IP addresses to
organizations within differing physical areas (see also RFC2050).
This means that there is no central whois database for IP numbers.
This module allows the user to lookup the RIR who has authority for a
particular IP address. After finding out the authority for an IP address,
it is possible to use the authority's whois server to lookup the netblock owner.
=head1 CONSTRUCTOR
The constructor takes no arguments.
use IP::Authority;
my $reg = IP::Authority->new();
=head1 OBJECT METHODS
All object methods are designed to be used in an object-oriented fashion.
$result = $object->foo_method($bar,$baz);
Using the module in a procedural fashion (without the arrow syntax) won't work.
=over 4
=item $auth = $reg-E<gt>inet_atoauth(HOSTNAME)
Takes a string giving the name of a host, and translates that to an
two-letter string representing the regional Internet registry that has authority
of that IP address:
AR = ARIN (North America)
RI = RIPE (Europe)
LA = LACNIC (Latin America)
AP = APNIC (Asia-Pacific)
AF = AFRINIC (Africa and Indian Ocean)
IA = IANA (see RFC3330)
Takes arguments of both the 'rtfm.mit.edu' type and '18.181.0.24'. If the
host name cannot be resolved, returns undef. If the resolved IP address is not
contained within the database, returns undef. For multi-homed hosts (hosts
with more than one address), the first address found is returned.
=item $auth = $reg-E<gt>inet_ntoauth(IP_ADDRESS)
Takes a string (an opaque string as returned by Socket::inet_aton())
and translates it into a two-letter string representing the regional Internet
registry that has authority of that IP address:
AR = ARIN (North America)
RI = RIPE (Europe)
LA = LACNIC (Latin America)
AP = APNIC (Asia-Pacific)
AF = AFRINIC (Africa and Indian Ocean)
IA = IANA (see RFC3330)
If the IP address is not contained within the database, returns undef.
=item $t = $reg-E<gt>db_time()
Returns the creation date of the database, measured as number of seconds
since the Unix epoch (00:00:00 GMT, January 1, 1970). Suitable for feeding
to "gmtime" and "localtime".
=back
=head1 BUGS/LIMITATIONS
Only works with IPv4 addresses and ASCII hostnames.
=head1 SEE ALSO
L<IP::Country> - fast lookup of country codes from IP address.
L<http://www.apnic.net> - Asia-Pacific
L<http://www.ripe.net> - Europe
L<http://www.arin.net> - North America
L<http://www.lacnic.net> - Latin America
L<http://www.afrinic.net> - Africa and Indian Ocean
=head1 COPYRIGHT
Copyright (C) 2002-2005 Nigel Wetters Gourlay. All Rights Reserved.
NO WARRANTY. This module is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
Some parts of this software distribution are derived from the APNIC,
LACNIC, ARIN, AFRINIC and RIPE databases (copyright details below).
I am not a lawyer, so please direct questions about the RIR's
licenses to them, not me.
=head1 APNIC conditions of use
The files are freely available for download and use on the condition
that APNIC will not be held responsible for any loss or damage
arising from the application of the information contained in these
reports.
APNIC endeavours to the best of its ability to ensure the accuracy
of these reports; however, APNIC makes no guarantee in this regard.
In particular, it should be noted that these reports seek to
indicate the country where resources were first allocated or
assigned. It is not intended that these reports be considered
as an authoritative statement of the location in which any specific
resource may currently be in use.
=head1 ARIN database copyright
Copyright (c) American Registry for Internet Numbers. All rights reserved.
The ARIN WHOIS data is for Internet operational or technical research
purposes pertaining to Internet operations only. It may not be used for
advertising, direct marketing, marketing research, or similar purposes.
Use of the ARIN WHOIS data for these activities is explicitly forbidden.
ARIN requests to be notified of any such activities or suspicions thereof.
=head1 RIPE database copyright
The information in the RIPE Database is available to the public
for agreed Internet operation purposes, but is under copyright.
The copyright statement is:
"Except for agreed Internet operational purposes, no part of this
publication may be reproduced, stored in a retrieval system, or transmitted,
in any form or by any means, electronic, mechanical, recording, or
otherwise, without prior permission of the RIPE NCC on behalf of the
copyright holders. Any use of this material to target advertising
or similar activities is explicitly forbidden and may be prosecuted.
The RIPE NCC requests to be notified of any such activities or
suspicions thereof."
=head1 LACNIC database copyright
Copyright (c) Latin American and Caribbean IP address Regional Registry. All rights reserved.
=head1 AFRINIC copyright
Seems to be the RIPE copyright. I'm sure they'll correct this in due course.
=cut