Net::RBLClient - Queries multiple Realtime Blackhole Lists in parallel

    use Net::RBLClient;
    my $rbl = Net::RBLClient->new;
    $rbl->lookup('211.101.236.160');
    my @listed_by = $rbl->listed_by;

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

use vars qw( $VERSION $ip_pat );
$ip_pat = qr(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3});
$VERSION = '0.4';

sub new {
    my($class, %args) = @_;
    my $self = {
        lists       => [ lists() ],
        query_txt   => 0,
        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 }; 
    }
    if($self->{ server } eq 'resolv.conf') {
        local *F;
        open F, '/etc/resolv.conf'
            or die "Can't open resolv.conf: $!";
        local $/;
        my $resolv = <F>;
        if($resolv =~ /^nameserver\s+($ip_pat)/m) {
            $self->{ server } = $1;
        }
        else {
            die "No nameserver found in resolv.conf; specify one in constructor";
        }
    }
    $self;
}

sub lookup {
    my($self, $target_ip) = @_;
    $target_ip =~ /^$ip_pat$/
        or die "Invalid ip: '$target_ip' - must be dotted quad";
    my $start_time = time;
    my $qip = join '.', reverse(split /\./, $target_ip);
    my $deadline = time + $self->{ max_time };

    my $sock = IO::Socket::INET->new(
        Proto     => 'udp',
        PeerPort  => 53,
        PeerAddr  => $self->{ server },
    ) or die "Failed to create UDP client";

    if ( $self->{ query_txt } ) {
        foreach my $list(@{ $self->{ lists } }) {
            my($msg_a, $msg_t) = mk_packet($qip, $list);
            foreach ($msg_a, $msg_t) { $sock->send($_) or die "send: $!" }
        }
    }
    else {
        foreach my $list(@{ $self->{ lists } }) {
            my $msg = mk_packet($qip, $list);
            $sock->send($msg) || die "send: $!";
        }
    }
    my $dur = time - $start_time;

    $self->{ results } = {};
    $self->{ txt } = {};

    # Keep recv'ing packets until one of the exit conditions is met:

    my $needed = @{ $self->{ lists } }; # how many packets needed back
    $needed <<= 1 if $self->{ query_txt };
    my $hits = my $replies = 0;

    while($needed && time < $deadline) {
        my $msg = '';
        eval {
            local $SIG{ ALRM } = sub { die "alarm time out" };
            alarm $self->{ timeout };
            $sock->recv($msg, $self->{ udp_maxlen })  || die "recv: $!";
            alarm 0;
            1; # eval was OK
        };
        if($msg) {
            my ($domain, $res, $type) = decode_packet($msg);
            if ( defined $type && $type eq 'TXT' ) {
                $self->{ txt }{ $domain } = $res
            }
            elsif ($res) {
                $replies ++;
                $hits ++ if $res;
                $self->{ results }{ $domain } = $res;
                return 1 if    $hits >= $self->{ max_hits } ||
                            $replies >= $self->{ max_replies };
            }
            $needed --;
        }
    }
    1;
}

sub listed_by {
    my $self = shift;
    sort keys %{ $self->{ results } };
}

sub listed_hash {
    my $self = shift;
    %{ $self->{ results } };
}

sub txt_hash {
    my $self = shift;
    warn <<_ unless $self->{ query_txt };
Without query_txt turned on, you won't get any results from ->txt_hash().
_
    if (wantarray) { %{ $self->{ txt } } }
    else { $self->{ txt } }
}

# End methods - begin internal functions

sub mk_packet {
    # pass me a REVERSED dotted quad ip (qip) and a blocklist domain
    my($qip, $list) = @_;
    my($packet, $error) = new Net::DNS::Packet my $fqdn = "$qip.$list", 'A';
    die "Cannot build DNS query for $fqdn, type A: $error" unless $packet;
    return $packet->data unless wantarray;
    (my $txt_packet, $error) = new Net::DNS::Packet $fqdn, 'TXT', 'IN';
    die "Cannot build DNS query for $fqdn, type TXT: $error" unless $txt_packet;
    $packet->data, $txt_packet->data;
}

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 ];
}

# lists removed due to osirusoft outage:

        # spews.relays.osirusoft.com
        # spamsites.relays.osirusoft.com
        # spamhaus.relays.osirusoft.com
        # socks.relays.osirusoft.com
        # relays.osirusoft.com
        # proxy.relays.osirusoft.com
        # inputs.relays.osirusoft.com
        # dialups.relays.osirusoft.com
        # blocktest.relays.osirusoft.com

sub lists {
    qw(
        badconf.rhsbl.sorbs.net
        bl.reynolds.net.au
        bl.spamcop.net
        blackhole.compu.net
        blackholes.brainerd.net
        blackholes.five-ten-sg.com
        blackholes.intersil.net
        blackholes.wirehub.net
        block.blars.org
        block.dnsbl.sorbs.net
        dev.null.dk
        dnsbl.njabl.org
        dul.dnsbl.sorbs.net
        dynablock.wirehub.net
        flowgoaway.com
        formmail.relays.monkeys.com
        http.dnsbl.sorbs.net
        http.opm.blitzed.org
        korea.services.net
        list.dsbl.org
        misc.dnsbl.sorbs.net
        multihop.dsbl.org
        no-more-funn.moensted.dk
        nomail.rhsbl.sorbs.net
        opm.blitzed.org
        orbs.dorkslayers.com
        pm0-no-more.compu.net
        proxies.monkeys.com
        proxies.relays.monkeys.com
        psbl.surriel.com
        relays.dorkslayers.com
        relays.ordb.org
        relays.visi.com
        smtp.dnsbl.sorbs.net
        socks.dnsbl.sorbs.net
        socks.opm.blitzed.org
        spam.dnsbl.sorbs.net
        spamguard.leadmon.net
        spammers.v6net.org
        spamsources.fabel.dk
        spews.bl.reynolds.net.au
        unconfirmed.dsbl.org
        web.dnsbl.sorbs.net
        work.drbl.croco.net
        zombie.dnsbl.sorbs.net
        ztl.dorkslayers.com
    );
}
1;

__END__

1;