#!/usr/bin/perl
package Net::DNS::ToolKit::Utilities;

use strict;
#use diagnostics;

use vars qw($VERSION @ISA @EXPORT_OK $ID);

$VERSION = do { my @r = (q$Revision: 0.04 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };

use AutoLoader 'AUTOLOAD';

use Config;
use IO::Socket;
use Net::DNS::Codes qw(
	T_ANY
	T_A
	T_TXT
	T_MX
	T_NS
	T_SOA
	T_PTR
	T_CNAME
	C_IN
	NS_PACKETSZ
	QUERY
	NOERROR
	BITS_QUERY
	RD
);
use Net::DNS::ToolKit qw(
	put16
	get16
	gethead
	newhead
	get_ns
);
use Net::DNS::ToolKit::RR;
	
$ID = time % 65536;	# unique for now

require Exporter;
@ISA = qw(Exporter);

@EXPORT_OK = qw(
	id
	question  
	revIP   
	query  
	dns_udpsend
	dns_udpresp
	dns_ans
	dns_ns
	dns_ptr
	rlook_send
	rlook_rcv
);

# autoload declarations

sub DESTROY{};

1;
__END__

=head1 NAME

Net::DNS::ToolKit::Utilities - a collection of helper utilities

=head1 SYNOPSIS

  use Net::DNS::ToolKit::Utilities qw(
	id
	question  
	revIP   
	query  
	dns_udpsend
	dns_udpresp
	dns_ans
	dns_ns
	dns_ptr
	rlook_send
	rlook_rcv
  );

  $unique = id($seed);
  $querybuf = question($name,$type);
  $rev = revIP($ip);
  $response = query(\$buffer,$timeout);
  $socket = dns_udpsend(\$buffer,$timeout);
  $response = dns_udpresp($socket,$timeout);
  ($aptr,$tptr,$auth_zone) = dns_ans(\$buffer);
  $nsptr = dns_ns(\$buffer);
  $hostname = dns_ptr(\$buffer);
  $socket = rlook_send($IP,$timeout);
  $hostname = rlook_rcv($socket,$timeout);

=head1 DESCRIPTION

B<Net::DNS::ToolKit::Utilities> provides a collection of DNS utilities
built from the ToolKit building blocks

=over 4

=item * $unique = id($seed);

Return a unique, non-zero, 16 bit ID for this session. Seeded with time, this number is
autoincremented each time it is retrieved and will be unique each call from
a single session. The number wraps around at 65535.

  input:	[optional] seed
  returns:	the last 16 bit number +1

Optionally, the user may supply a seed for the first call. Subsquent calls
will return the previous number + 1 (mod 65536). The seed is set when the module is
instantiated if no seed is supplied.

=cut

sub id {
  my $seed = shift;
  $ID = ($seed % 65536) if $seed;
  $ID = 1 if ++$ID > 65535;
  return $ID;
}

=item * $querybuf = question($name,$type);

Create a C_IN DNS query of $type about $name.

  input:	host or domain name,
		query type
  returns:	query buffer

Supports types T_A, T_TXT, T_ANY, T_MX, T_NS, T_PTR  

=cut

sub question {
  my ($name,$type) = @_;
  return undef unless
	$type == T_NS ||
	$type == T_MX ||
	$type == T_ANY ||
	$type == T_TXT ||
	$type == T_PTR ||
	$type == T_A;

  my $buffer;
  my $offset = newhead(\$buffer,
	&id(),
	BITS_QUERY | RD,		# query, recursion desired
	1,0,0,0,			# one question
  );
  my ($get,$put,$parse) = new Net::DNS::ToolKit::RR;
  $offset = $put->Question(\$buffer,$offset,$name,$type,C_IN);
  return $buffer;
}

=item * $rev = revIP($ip);

Reverse an IP address. i.e

  78.56.34.12 = revIP(12.34.56.78);

  input:	a dot quad IP address
  returns:	reversed dot quad address

NOTE: this is an operation on ASCII characters, not packed network
addresses.

=cut

sub revIP {
  my @ip = split(/\./, shift);
  @_ = reverse @ip;
  return join('.',@_);
}
  
=item * $response = query(\$buffer,$timeout);

Sends a DNS query contained in $buffer. Return a DNS
response buffer or undef on error. If the error is catastophic (like a
timeout), $@ will be set.

  input:	pointer to query buffer,
		optional timeout (secs, def 30)
  returns:	DNS answer or undef

=cut

sub query {
  my($bp,$timeout) = @_;
  $timeout = 30 unless $timeout && $timeout > 0;
  my @servers = get_ns();
  my $port = 53;
  my ($msglen,$response);
  my $len = length($$bp);
  foreach my $server (@servers) {
    $server = inet_ntoa($server);
    eval {
      local $SIG{ALRM} = sub {die "connection timed out, no servers could be reached"};
      alarm $timeout;
##### open socket
      my $socket = IO::Socket::INET->new(
	PeerAddr	=> $server,
	PeerPort	=> $port,
	Proto		=> 'udp',
	Type		=> SOCK_DGRAM,
      ) or die "connection timed out, no servers could be reached";

##### send UDP query
      syswrite $socket, $$bp, length($$bp);
##### read UDP answer
      unless ($msglen = sysread($socket,$response,NS_PACKETSZ)) {	# get response, size limited
	close $socket;

	$socket = IO::Socket::INET->new(
	  PeerAddr	=> $server,
	  PeerPort	=> $port,
	  Proto		=> 'tcp',
	  Type		=> SOCK_STREAM,
	) or die "connection timed out, no servers could be reached";

##### send TCP query
	put16(\$msglen,0,$len);
	syswrite $socket, $msglen, 2;
	syswrite $socket, $$bp, $len;

##### read TCP answer
	sysread $socket, $response, 2;

	$msglen = get16(\$response,0);
	$msglen = sysread $socket, $response, $msglen;
      } # using TCP
      close $socket;
      alarm 0;
    }; # end eval
    next if $@;
    next unless $msglen;
    return $response;
  } # end if foreach, no server found
  return undef;
}

=item * $socket = dns_udpsend(\$buffer,$timeout);

Sends a DNS query contained in $buffer. Returns a UDP socket or undef;
If the error is catastophic (like a timeout), $@ will be set.

  input:	pointer to query buffer,
		optional timeout (secs, def 30)
  returns:	socket or undef

=cut

sub dns_udpsend {
  my($bp,$timeout) = @_;
  $timeout = 30 unless $timeout && $timeout > 0;
  my @servers = get_ns();
  my $port = 53;
  my $len = length($$bp);
  my $server = inet_ntoa($servers[0]);
  my $socket;
  eval {
      local $SIG{ALRM} = sub {die "connection timed out, no servers could be reached"};
      alarm $timeout;
##### open socket
      $socket = IO::Socket::INET->new(
	PeerAddr	=> $server,
	PeerPort	=> $port,
	Proto		=> 'udp',
	Type		=> SOCK_DGRAM,
      ) or die "connection timed out, no servers could be reached";

##### send UDP query, should not block
      syswrite $socket, $$bp, length($$bp);
      alarm 0;
  };
  return $socket;
}

=item * $buffer = dns_udpresp($socket,$timeout);

Returns a DNS answer from $socket and closes socket. Returns undef on
failure. If the error is catastophic (like a timeout), $@ will be set.

  input:	socket,
		optional timeout (secs, def 30)
  returns:	response buffer

  closes:	socket

=cut

sub dns_udpresp {
  my($socket,$timeout) = @_;
  return undef unless $socket;
  $timeout = 30 unless $timeout && $timeout > 0;
  my $response = undef;
  eval {
      local $SIG{ALRM} = sub {die "connection timed out, no servers could be reached"};
      alarm $timeout;
      sysread($socket,$response,NS_PACKETSZ) or die "no message received";
  };
  alarm 0;
  close $socket;
  return $response;
}

=item * ($aptr,$tptr,$auth_zone)=dns_ans(\$buffer);

Parse a DNS answer and return pointer to an array of B<A> response records
and B<TXT> records blessed into the callers namespace.

  input:	DNS answer
  returns:	pointers to two arrays,
		auth_zone name or ''

Returns an empty array unless there is at least ONE B<A> record found.

The first array contains packed IPv4 addresses of the form
returned by inet_aton (text). The second array contains text strings.

auth_zone will contain the zone name if an SOA record is found, otherwise
it will contain ''.

=cut

sub dns_ans {
  my $bp = shift;
  my $aptr = [];
  my $tptr = [];
  my $zone = '';
  my ($caller) = caller;
  my ($off,$id,$qr,$opcode,$aa,$tc,$rd,$ra,$mbz,$ad,$cd,$rcode,
	$qdcount,$ancount,$nscount,$arcount)
	= gethead($bp);

  DECODE:
  while(1) {
    last if
	$tc ||
	$opcode != QUERY ||
	$rcode != NOERROR ||
	$qdcount != 1 ||
	$ancount < 1;

    my ($get,$put,$parse) = new Net::DNS::ToolKit::RR;
    my ($off,$name,$type,$class) = $get->Question($bp,$off);
    last unless $class == C_IN;

    foreach(0..$ancount -1) {
      ($off,$name,$type,$class,my($ttl,$rdlength,@rdata)) =
	$get->next($bp,$off);
      if ($type == T_A) {
	push @$aptr, @rdata;
      } elsif ($type == T_TXT) {
	if (@rdata > 1) {
	  push @$tptr, join(' ',@rdata);
	} else {
	  push @$tptr, @rdata;
	}
      }
    }
    last if $ancount && @$aptr;	# end, if there is an answer
    last unless $arcount;	# end if there is no authority
    foreach(0..$nscount -1) {
      ($off,@_) = $get->next($bp,$off);	# toss these
    }
    foreach(0..$arcount -1) {
      ($off,$name,$type,@_) =
	$get->next($bp,$off);
      if($type == T_SOA) {
	$zone = $name;
	last DECODE;
      }
    }
    last;
  }
  return () unless @$aptr;
  bless $aptr, $caller;
  bless $tptr, $caller;
  return($aptr,$tptr,$zone);
}

=item * $nsptr = dns_ns(\$buffer);

Parse a DNS NS request answer and return pointer to a hash of name servers
and TTL's.

  $ptr->{hostname}--->{addr} = netaddr
		   |
		   *->{ttl}  = seconds

If no records are found, undef is returned

  input:	pointer to response buffer
  returns:	pointer to hash or undef

=cut

sub dns_ns {
  my $bp = shift;
  my $nsptr = {};
  my @ns;
  my ($caller) = caller;
  my ($off,$id,$qr,$opcode,$aa,$tc,$rd,$ra,$mbz,$ad,$cd,$rcode,
	$qdcount,$ancount,$nscount,$arcount)
	= gethead($bp);

  DECODE:
  while(1) {
    last if
	$tc ||
	$opcode != QUERY ||
	$rcode != NOERROR ||
	$qdcount != 1 ||
	$ancount < 1 ||
	$arcount < 1;

    my ($get,$put,$parse) = new Net::DNS::ToolKit::RR;
    my ($off,$name,$type,$class) = $get->Question($bp,$off);
    last unless $class == C_IN;

    foreach(0..$ancount -1) {
      ($off,$name,$type,$class,my($ttl,$rdlength,@rdata)) =
	$get->next($bp,$off);
      if ($type == T_NS) {
	push @ns, @rdata;
      }
    }
    last unless @ns;		# end if there is no answer
    foreach(0..$nscount -1) {
      ($off,@_) = $get->next($bp,$off); # toss these
    }
    foreach(0..$arcount -1) {
      ($off,$name,$type,$class,my($ttl,$rdlength,@rdata)) =
	$get->next($bp,$off);
      if ($type == T_A && grep($name eq $_,@ns)) {
	$nsptr->{"$name"}->{addr} = $rdata[0];	# return first available ns address
	$nsptr->{"$name"}->{ttl} = $ttl;
      }
    }
    last;
  }
  return undef unless keys %$nsptr;
  bless $nsptr, $caller;
  return $nsptr;
}

=item * $host = dns_ptr(\$buffer);

Parse a DNS PTR request answer and return the hostname

If no records are found, undef is returned

  input:	pointer to response buffer
  returns:	host name

=cut

sub dns_ptr {
  my $bp = shift;
  return undef unless $$bp;
  my ($off,$id,$qr,$opcode,$aa,$tc,$rd,$ra,$mbz,$ad,$cd,$rcode,
	$qdcount,$ancount,$nscount,$arcount)
	= gethead($bp);

  return undef if
	$tc ||
	$opcode != QUERY ||
	$rcode != NOERROR ||
	$qdcount != 1 ||
	$ancount < 1;

  my ($get,$put,$parse) = new Net::DNS::ToolKit::RR;
  ($off,my($name,$type,$class)) = $get->Question($bp,$off);
  return undef unless $class == C_IN;

  my($ttl,$rdlength,$host);
  while (1) {
    ($off,$name,$type,$class,$ttl,$rdlength,$host) =
	$get->next($bp,$off);
    last if $type == T_PTR;
    next if $type == T_CNAME;
    return undef;			# not a PTR or CNAME record
  }
  ($name,$type,$class,$host) = $parse->PTR($name,$type,$class,$host);
  return $host;
}

=item * $socket = rlook_send($IP,$timeout);

Send a query for reverse lookup of $IP 
and return the receive socket handle.

  input:	dotquad IP address,
		optional timeout (sec, def 30)
  return:	socket or undef

=cut

sub rlook_send {
  my($IP,$timeout) = @_;
  my $buffer = undef;
  my $offset = newhead(\$buffer,
	&id(),
	BITS_QUERY | RD,	# query, recursion desired
	1,0,0,0,		# one question
  );
  my $dnsblIP = revIP($IP);
  my ($get,$put,$parse) = new Net::DNS::ToolKit::RR;
  $offset = $put->Question(\$buffer,$offset,$dnsblIP.'.in-addr.arpa',T_PTR,C_IN);
 return dns_udpsend(\$buffer,$timeout);
}

=item * $hostname = rlook_rcv($socket,$timeout);

Receive DNS response, parse for hostname, close socket;

  input:	receive socket,
		optional timeout (sec, def 30)
  return:	hostname text or undef

=back

=cut

sub rlook_rcv {
  my $buffer = dns_udpresp(@_);
  return dns_ptr(\$buffer);
}

=head1 DEPENDENCIES

	IO::Socket
        Net::DNS::Codes
        Net::DNS::ToolKit
        Net::DNS::ToolKit::RR

=head1 EXPORT

        none by default

=head1 EXPORT_OK

        id   
        question
        revIP
        query
        dns_udpsend
        dns_udpresp
        dns_ans
        dns_ns
        dns_ptr
        rlook_send
        rlook_rcv 

=head1 COPYRIGHT

Copyright 2003, 2004 Michael Robinton <michael@bizsystems.com>

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or   
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of 
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the  
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

=head1 AUTHOR

Michael Robinton <michael@bizsystems.com>

=head1 SEE ALSO

L<Net::DNS::Codes>, L<Net::DNS::ToolKit>, L<Net::DNS::ToolKit::RR>,

=cut

1;