#!/usr/bin/perl -W

use warnings;
use Net::DNS;
use IO::Socket::INET;
use Net::DNS::Packet qw(dn_expand);
use Benchmark;
use strict;


#my $count = 900_000;
my $count =7000;

our $r = Net::DNS::Resolver->new();
$r->persistent_udp(1);
$r->force_v4;
our $s =  IO::Socket::INET->new( PeerAddr => (($r->nameserver)[0]), 
                                    PeerPort => '53',
                                    Proto => 'udp');

our %RTYPES = ( 'A' => 1, 'TXT' => 16 ); # see RFC 1035
our @a;
our $i;


our $query = 'maiil.ek-muc.de';

timethese($count, 
{
    'net-dns' => sub 
    {
      $r->send($query, 'TXT');
    },
    'own' => sub 
    {
        rbl_lookup($query, 'TXT');
    }
});


# rbl_lookup RBL_QUERY [TYPE] # 1: found, -1: not found, 0: error
# remember to give IP octets in reversed order.
# EG: IP: 121.122.123.124, Host: mail.example.com, Rbl: bl.rbl.com
# RBL_QUERY  : "124.123.122.121.bl.rbl.com"
# RHSBL_QUERY: "mail.example.com.bl.rbl.com"
# TYPE is additonal and usually not needed, default is TXT
sub rbl_lookup
{
        my $preq;
        my $query = shift(@_);
        if($query =~ /[^.]{64}/) { die "length!" };
        my $rtype = shift(@_);
        $rtype = 'TXT' unless $RTYPES{$rtype};

        my $oid = int(rand()*65536);
                              #  ID    RD      QDCOUNT
        my $p = pack ("n*", $oid, 0x100,  1,        0, 0, 0) .

        # concatenate the query and pack it into length preceded labels
        # labels are the names between the dots.
                pack ("(C/A*)*", split /\./, $query ) .
                pack ("@ (n*)*", $RTYPES{$rtype},      1);
#                                ^QTYPE                ^QCLASS    see: RFC 1035 
      
 
        $SIG{ALRM} = sub { return };
        
        my $buf;
        my $errcnt = 0;
        my $RETRIES = 2;
        my $TIMEOUT = 2; # in sec
        my $dropped = 0;
        while(1)
        {
            alarm 0; # reset all eventually alarms
            if(!($dropped))
            {
                alarm $TIMEOUT;
                if($s->send($p) < length($p))
                {
                    ++$errcnt; # timeout or erro on sending
                    next;
                }
            }
            $dropped = 0;
            alarm $TIMEOUT;
            my $buf;
            $s->recv($buf, 512); 
            if((!($buf)) && ($errcnt < $RETRIES))
            {
                ++$errcnt;
                $s->send($p);
                next;
            }
            elsif($errcnt >= $RETRIES)
            {   
                return(0);  # too many timeouts or errors
            }
            my        ($id, $bf, $qc, $anc, $nsc, $arc, $qb) = 
                unpack("n   n    n    n     n     n     a*",   $buf);
            
            my ($dn, $offset) = dn_expand(\$qb, 0);
            if(($id && $anc) && ($id == $oid) && ($query eq $dn))
            {
                return(1);  # found
            }
            elsif($id && (!($anc)) && $qb && ($id == $oid) && ($query eq $dn))
            {
                return(-1); # not found
            }
            elsif($id && (($query ne $dn) || ($id != $oid)))
            {
                $dropped = 1;
                next;       # wrong packet received, drop
            }
            ++$errcnt;      # unknown error
        }
}