Net::Blacklist::Client - Queries multiple RBLs or URIBLs in parallel.

	use Net::Blacklist::Client;
	my $rbl = Net::Blacklist::Client->new;
	my $result = $rbl->lookup_ip('127.0.0.2');
	foreach my $list (keys %$result){
		printf "%s: %s (%s)\n", $list, $result->{$list}->{a}, $result->{$list}->{txt};
	}

package Net::Blacklist::Client;

# Many thanks to Asher Blum <asher@wildspark.com> for the original
# Net::RBLClient, from which this module unashamedly steals.

use strict;
use warnings;

use IO::Socket;
use Time::HiRes qw(time);
use Net::DNS::Packet;

use vars qw($VERSION $ip_re $domain_re);
$ip_re = qr(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3});
$domain_re = qr([a-zA-Z0-9-]{1,63}(?:\.[a-zA-Z0-9-]{1,63})*\.[a-zA-Z0-9]{1,6});

$VERSION = '0.3';

sub new {
	my($class, %args) = @_;
	my $self = {
		lists_domain	=> [ lists_domain() ],
		lists_ip		=> [ lists_ip() ],
		query_txt		=> 1,
		max_time		=> 8,
		timeout			=> 1,
		max_hits		=> 1000,
		max_replies		=> 1000,
		udp_maxlen		=> 4000,
		server			=> 'resolv.conf',
	};
	bless($self, $class);

	foreach my $key (keys %args) {
		defined($self->{$key}) or die "Invalid key: $key";
		$self->{$key} = $args{$key}; 
	}

	# Read the contents of resolv.conf and set the server to the first
	# nameserver we find listed, if the server is set to 'resolv.conf'
	if ($self->{server} eq 'resolv.conf'){
		open my $resolv_fh, '/etc/resolv.conf' or die "Can't open resolv.conf: $!";
		local $/;
		my $resolv = <$resolv_fh>;

		if ($resolv =~ /^nameserver\s+($ip_re)/m){
			$self->{server} = $1;
		}else{
			die "No nameserver found in resolv.conf; specify a nameserver IP in constructor";
		}
	}
	return $self;
}

sub lookup_domain{
	my ($self, $domain) = @_;
	die "Do not recognise domain '$domain'" unless $domain =~ /^$domain_re$/;
	return $self->lookup_all(lc($domain), $self->{lists_domain});
}
sub lookup_ip{
	my ($self, $ip) = @_;
	die "Do not recognise IP address '$ip'" unless $ip =~ /^$ip_re$/;
	my $reverse_ip = join '.', reverse split(/\./, $ip);
	return $self->lookup_all($reverse_ip, $self->{lists_ip});
}

sub lookup_all{
	my ($self, $partial, $lists) = @_;
	foreach my $list (@$lists){
		my $query = join '.', ($partial, $list);

		# Send the A lookup
		$self->send_packet_a($query);

		# optionally send the TXT lookup
		if ($self->{query_txt}){
			$self->send_packet_txt($query);
		}
	}
	return $self->collect_responses;
}

sub collect_responses{
	my ($self) = @_;

	my $hits = my $replies = 0;
	my $deadline = time + $self->{max_time};
	my $results = {};

	# Continue receiving packets until:
	# * There are no more pending
	# * The timeout is exceeded
	# * Max hits or max replies are met
	while ($self->{_pending} > 0 && time < $deadline) {
		my $msg = '';
		eval{
			local $SIG{ALRM} = sub{ die "alarm time out" };
			alarm $self->{timeout};
			$self->sock->recv($msg, $self->{udp_maxlen}) || die "recv: $!";
			alarm 0;
			1;
		};
		if ($msg){
			my ($domain, $res, $type) = decode_packet($msg);
			if (defined $type && $type eq 'TXT' && $self->{query_txt}) {
				$results->{$domain}{txt} = $res;
			}elsif ($res){
				$replies++;
				$hits++ if $res;
				if ($self->{query_txt}){
					$results->{$domain}{a} = $res;
				}else{
					$results->{$domain} = $res;
				}
				return 1 if $hits >= $self->{max_hits} ||
							$replies >= $self->{max_replies};
			}
			$self->{_pending}--;
		}
	}
	$self->{_pending} = 0;
	return $results;
}


sub decode_packet{
	# takes a raw DNS response packet
	# returns domain, response
	my $data = shift;
	my $packet = Net::DNS::Packet->new(\$data);
	my @answer = $packet->answer;
	{
		my ($res, $domain, $type);
		foreach my $answer (@answer) {
			{
				# removed $answer->answerfrom because it caused an error
				# with some types of answers

				my $name = lc $answer->name;
				#warn "Packet contained answers to different domains ($domain != $name)"
				#	if defined $domain && $name ne $domain;
				$domain = $name;
			}
			$domain =~ s/^\d+\.\d+\.\d+\.\d+\.//;
			$type = $answer->type;
			$res = $type eq 'A'     ? inet_ntoa($answer->rdata)  :
				   $type eq 'CNAME' ?   cleanup($answer->rdata)  :
				   $type eq 'TXT'   ? (defined $res && "$res; ")
									  . $answer->txtdata         :
				   '?';
			last unless $type eq 'TXT';
		}
		return $domain, $res, $type if defined $res;
	}
	
	# OK, there were no answers -
	# need to determine which domain
	# sent the packet.

	my @question = $packet->question;
	foreach my $question(@question) {
		my $domain = $question->qname;
		$domain =~ s/^\d+\.\d+\.\d+\.\d+\.//;
		return ($domain, undef);
	}
}

sub cleanup {
	# remove control chars and stuff
	$_[ 0 ] =~ tr/a-zA-Z0-9./ /cs;;
	$_[ 0 ];
}


# Packet generation
sub send_packet_a{
	my ($self, $query) = @_;
	$self->send_packet($query, 'A');
}
sub send_packet_txt{
	my ($self, $query) = @_;
	$self->send_packet($query, 'TXT', 'IN');
}
sub send_packet{
	my ($self, $query, @pkt_args) = @_;
	my ($packet, $error) = Net::DNS::Packet->new($query, @pkt_args);
	die "Cannot build DNS query for $query, type $pkt_args[0]: $error" unless $packet;
	$self->sock->send($packet->data) || die "Could not sent $pkt_args[0] packet for query '$query': $!";
	$self->{_pending}++;
}

# returns a UDP socket connected to the specified server
sub sock{
	my ($self) = @_;
	$self->{_sock} ||= IO::Socket::INET->new(
		Proto     => 'udp',
		PeerPort  => 53,
		PeerAddr  => $self->{server},
	) or die "Failed to create UDP client";
	return $self->{_sock};
}


# Lists of lists..

sub lists_domain{
	return qw(
		multi.uribl.com
		multi.surbl.org
	);
}

sub lists_ip{
	return qw(
		0spam.fusionzero.com
		dnsbl.ahbl.org
		opm.blitzed.org
		cbl.abuseat.org
		bl.csma.biz
		sbl.csma.biz
		dnsbl.cyberlogic.net
		bl.deadbeef.com
		spamsources.dnsbl.info
		dnsbl.net.au
		t1.dnsbl.net.au
		dun.dnsrbl.net
		spam.dnsrbl.net
		list.dsbl.org
		unconfirmed.dsbl.org
		multihop.dsbl.org
		spamsources.fabel.dk
		blackholes.five-ten-sg.com
		hil.habeas.com
		blocked.hilli.dk
		blackholes.intersil.net
		ipwhois.rfc-ignorant.org
		dnsbl.jammconsulting.com
		3y.spam.mrs.kithrup.com
		relays.bl.kundenserver.de
		spamguard.leadmon.net
		relays.nether.net
		unsure.nether.net
		combined.njabl.org
		no-more-funn.moensted.dk
		dnsbl.antispam.or.id
		relays.ordb.org
		psbl.surriel.com
		dnsbl.rangers.eu.org
		access.redhawk.org
		dnsbl.regedit64.net
		relays.visi.com
		sbbl.they.com
		sbl.spamhaus.org
		xbl.spamhaus.org
		rbl.snark.net
		dnsbl.solid.net
		dnsbl.sorbs.net
		blacklist.spambag.org
		bl.spamcannibal.org
		bl.spamcop.net
		map.spam-rbl.com
		bl.spamthwart.com
		l1.spews.dnsbl.sorbs.net
		l2.spews.dnsbl.sorbs.net
		block.dnsbl.sorbs.net
		bl.technovision.dk
		blackholes.uceb.org
		dnsbl-1.uceprotect.net
		dnsbl-2.uceprotect.net
		virbl.dnsbl.bit.nl
		vox.schpider.com
		db.wpbl.info
		ubl.unsubscore.com
		dnsbl.tqmcube.com
		abuse.rfc-ignorant.org
		bogusmx.rfc-ignorant.org
		dsn.rfc-ignorant.org
		postmaster.rfc-ignorant.org
		whois.rfc-ignorant.org
		ex.dnsbl.org
		in.dnsbl.org
		unconfirmed.dsbl.org
		list.dsbl.org
	);
}

1;