package Tie::DNS;
our $VERSION = '0.5';
use Carp;
use strict;
use warnings;
use Net::DNS;

my %config_rec_defaults = (
	'AAAA'	=>	'address',
	'AFSDB'	=>	'subtype',
	'A'	=>	'address',
	'CNAME'	=>	'cname',
	'EID'	=>	'rdlength',
	'HINFO'	=>	'cpu',
	'ISDN'	=>	'address',
	'LOC'	=>	'version',
	'MB'	=>	'madname',
	'MG'	=>	'mgmname',
	'MINFO'	=>	'rmailbx',
	'MR'	=>	'newname',
	'MX'	=>	'exchange',
	'NAPTR'	=>	'order',
	'NIMLOC'	=>	'rdlength',
	'NSAP'	=>	'idp',
	'NS'	=>	'nsdname',
	'NULL'	=>	'rdlength',
	'PTR'	=>	'ptrdname',
	'PX'	=>	'preference',
	'RP'	=>	'mbox',
	'RT'	=>	'intermediate',
	'SOA'	=>	'mname',
	'SRV'	=>	'target',
	'TXT'	=>	'txtdata');

my %config_type = (
	'AAAA'	=>	['address', 'ttl'],
	'AFSDB'	=>	['subtype', 'ttl'],
	'A'	=>	['address', 'ttl'],
	'CNAME'	=>	['cname', 'ttl'],
	'EID'	=>	['rdlength', 'rdata', 'ttl'],
	'HINFO'	=>	['cpu', 'os', 'ttl'],
	'ISDN'	=>	['address', 'subaddress', 'ttl'],
	'LOC'	=>	['version', 'size', 'horiz_pre', 'vert_pre', 'latitude', 'longitude', 'latlon', 'altitude', 'ttl'],
	'MB'	=>	['madname', 'ttl'],
	'MG'	=>	['mgmname', 'ttl'],
	'MINFO'	=>	['rmailbx', 'emailbx', 'ttl'],
	'MR'	=>	['newname', 'ttl'],
	'MX'	=>	['exchange', 'preference'],
	'NAPTR'	=>	['order', 'preference', 'flags', 'service', 'regexp', 'replacement', 'ttl'],
	'NIMLOC'	=>	['rdlength', 'rdata', 'ttl'],
	'NSAP'	=>	['idp', 'dsp', 'afi', 'idi', 'dfi', 'aa', 'rsvd', 'rd', 'area', 'id', 'sel', 'ttl'],
	'NS'	=>	['nsdname', 'ttl'],
	'NULL'	=>	['rdlength', 'rdata', 'ttl'],
	'PTR'	=>	['ptrdname', 'ttl'],
	'PX'	=>	['preference', 'map822', 'mapx400', 'ttl'],
	'RP'	=>	['mbox', 'txtdname','ttl'],
	'RT'	=>	['intermediate', 'preference', 'ttl'],
	'SOA'	=>	['mname', 'rname', 'serial', 'refresh', 'retry', 'expire', 'minimum', 'ttl'],
	'SRV'	=>	['target', 'port', 'weight', 'priority', 'ttl'],
	'TXT'	=>	['txtdata', 'ttl']);

sub
TIEHASH {
	my $class = shift;
	my $args = shift;

	if(defined($args)) {
		die "Bad argument format" unless(ref($args) eq 'HASH');
	}

	my $self = {};
	bless $self, $class;
	$self->{'dns'} = new Net::DNS::Resolver;

	$self->args($args);

	return ($self);
}

sub
STORE {	#Dynamic update.  Oh my.  :-)
	my $self = shift;
	my $key = shift;
	my $value = shift;

	my $root_server = $self->get_root_server || 
		die("Dynamic update attempted but no (or bad) domain specified.");

	my $update = new Net::DNS::Update($self->get_arg('domain'));
	my $update_string = sprintf('%s. %s %s %s', 
		$key, $self->{'ttl'}, $self->{'lookup_type'}, $value);
	$update->push('update', rr_add($update_string));

	my $res = new Net::DNS::Resolver;
	$res->nameservers($root_server);
	my $reply = $res->send($update);
	if(defined($reply)) {
		if($reply->header->rcode eq 'NOERROR') {
			return($value);
		} else {
			$self->{'errstring'} = $self->{'dns'}->errorstring;
			return(undef);
		}
	} else {
		$self->{'errstring'} = $self->{'dns'}->errorstring;
		return(undef);
	}
}

sub
args {
	my $self = shift;
	my $args = shift;
	$self->{'args'} = $args;
	$self->process_args;
}

sub
FETCH {
	my $self = shift;
	my $lookup = shift;

	if($lookup =~ /^\d+\.\d+\.\d+\.\d+$/) {
		return($self->do_reverse_lookup($lookup));
	} else {
		return($self->do_forward_lookup($lookup));
	}
}

sub
FIRSTKEY {
	my $self = shift;
	my @full_zone = $self->{'dns'}->axfr($self->{'root_name_server'});
	if(scalar(@full_zone) == 0) {
		$self->{'errstring'} = $self->{'dns'}->errorstring;
		return(undef);
	}

	my @zone;
	foreach my $rr (@full_zone) {
		push(@zone, $rr) if($rr->type eq 'A');
	}
	my $rr = shift(@zone);
	$self->{'zone'} = \@zone;
	return($rr->name);
}

sub
NEXTKEY {
	my $self = shift;
	my @zone = @{$self->{'zone'}};
	if(scalar(@zone) == 0) {
		return(undef);
	}
	my $rr = shift(@zone);
	$self->{'zone'} = \@zone;
	return($rr->name);
}

sub
CLEAR {
	my $self = shift;
#	die ("dynamic DNS updates are not yet available.");
}

sub
DELETE {
	my $self = shift;
	die ('Tie::DNS: DELETE function not implemented');
}

sub
DESTROY {
	my $self = shift;
	#There isn't any real Net::DNS requirement to call anything when
	#we go bye-bye, so we'll just go bye-bye quietly.
}

sub
process_args {
	my $self = shift;

	if(defined($self->get_arg('domain'))) {	#find the root name
						#server for this domain
		$self->{'root_name_server'} = $self->get_root_server;
		$self->{'dns'}->nameservers($self->{'root_name_server'});
	}

	if(defined($self->get_arg('multiple'))) {	#multiple return
							#objects
		#I don't think there's any setup required for this.
	}

	if(defined($self->get_arg('all_fields'))) {	#all fields
		#I don't think there's any setup for this one either.
	}

	if(defined($self->get_arg('type'))) {
		if(!defined($config_type{$self->get_arg('type')})) {
			die('Bad record type: ' . $self->get_arg('type'));
		}
		$self->{'lookup_type'} = $self->get_arg('type');
	} else {
		$self->{'lookup_type'} = 'A';
	}

	if(defined($self->get_arg('ttl'))) {
		$self->{'ttl'} = $self->get_arg('ttl');
	} else {
		$self->{'ttl'} = 86400;
	}

	if (my $cache_param = $self->get_arg('cache')) {
		eval 'require Tie::Cache';
		unless ($@) {
			tie my %cache, 'Tie::Cache', $cache_param;
			$self->{'cache'} = \%cache;
		}
	} else {
		delete $self->{'cache'};
	}
}


sub
get_root_server {
	my $self = shift;
	my $query = $self->{'dns'}->query($self->get_arg('domain'), 'SOA');
	if ($query) {
		foreach my $rr ($query->answer) {
			print "Root: $rr->mname\n";
			return($rr->mname);
		}
	} else {
		die 'Domain specified, but unable to get SOA record: ' . $self->{'dns'}->errorstring;
	}
}

sub
get_arg {
	my $self = shift;
	my $arg_name = shift;
	return(undef) unless(defined($self->{'args'}));

	return $self->{'args'}{$arg_name};
}

sub
do_reverse_lookup {
	my $self = shift;
	my $lookup = shift;

	my $query = $self->{'dns'}->search($lookup);
	my @retvals;
	if($query) {
		foreach my $rr ($query->answer) {
			next unless $rr->type eq 'PTR';
			push(@retvals, $rr->ptrdname);
		}
	} else {
		$self->{'errstring'} = $self->{'dns'}->errorstring;
		return(undef);
	}
	if(defined($self->get_arg('multiple'))) {
		return(\@retvals);
	} else {
		return(shift(@retvals));
	}
}

sub
do_forward_lookup {
	my $self = shift;
	my $lookup = shift;
	my @things = $self->lookup_to_thing($lookup);
	if(defined($self->get_arg('multiple'))) {
		return(\@things);
	} else {
		return(shift(@things));
	}
}

sub
ip_to_name {
	my $self = shift;
}

sub
lookup_to_thing {
	my $self = shift;
	my $lookup = shift;

	my $ttl = 0;
	my $now = time();
	my $cache = $self->{cache};

	if ($cache and my $old = $cache->{$lookup}) {
		my ($expire, $ret) = @$old;
		if ($now > $expire) {
			delete $cache->{$lookup};
		} else {
			return @$ret;
		}
	}

	my $query = $self->{'dns'}->search($lookup, $self->{'lookup_type'});

	my @retvals;
	if($query) {
		foreach my $rr ($query->answer) {
			$ttl ||= $rr->{ttl};
			next unless($rr->type eq $self->{'lookup_type'});
			if(defined($self->get_arg('all_fields'))) {
				my %fields;
				foreach my $field (
							@{$config_type{$self->{'lookup_type'}}}
								) {
					$fields{$field} = 
							$rr->{$field};
				}
				push(@retvals, \%fields);
			} else {
				push(@retvals, 
					$rr->{
					$config_rec_defaults{$self->{'lookup_type'}}
#					$config_type{$self->{'lookup_type'}}[0]
					});
			}
		}
	} else {
		$self->{'errstring'} = $self->{'dns'}->errorstring;
	}

	if ($cache) {
		$cache->{$lookup} = [ $now + $ttl, \@retvals ];
	}
	@retvals;
}
#$self->get_arg('all_fields')
sub
error {
	my $self = shift;
	return($self->{'errstring'});
}

1;
__END__

=head1 NAME

Tie::DNS - Tie interface to Net::DNS

=head1 VERSION

This document describes version 0.5 of Tie::DNS, released February 28, 2008

=head1 SYNOPSIS

  use Tie::DNS;

  tie(my %dns, 'Tie::DNS');

  print "$dns{'foo.bar.com'}\n";

  print "$dns{'208.180.41.1'}\n";

=head1 DESCRIPTION 

Net::DNS is a very complete, extensive and well-written module.  
It's completeness, however, makes many comman cases uses a bit
wordy, code-wise.  Tie::DNS is meant to make common DNS operations
trivial, and more complex DNS operations easier.

=head1 EXAMPLES

=head2 Forward lookup

See Above.

=head2 Zone transfer

Get all of the A records from 'foo.com'.  (Sorry foo.com if
everyone hits your name server testing this module.  :-)

  tie (%dns, 'Tie::DNS', {'Domain' => 'foo.com'});

  while (my ($name, $ip) = each %dns) {
        print "$name = $ip\n";
  }

This obviously requires that your host has zone transfer
privileges with a name server hosting that zone.  The
zone transfer is initiated with the first each, keys or
values operation.  The tie operation does a SOA query
to find the name server for the cited zone.

=head2 Fetching multiple records

Pass the configuration parameter of 'multiple' to any Perl true 
value, and all FETCH values from Tie::DNS will be an array
reference of records.

  tie (my %dns, 'Tie::DNS', {'multiple' => 'true'});

  my $ip_ref = $dns{'cnn.com'};
  foreach (@{$ip_ref}) {
	print "Address: $_\n";
  }


=head2 Fetching records of type besides 'A'

Pass the configuration parameter of 'type' to one of the
Net::DNS supported record types causes all FETCHes to
get records of that type.

  tie (%dns, 'Tie::DNS', {	'multiple' => 'true',
				'type' => 'SOA'});

  my $ip_ref = $dns{'cnn.com'};
  foreach (@{$ip_ref}) {
	print "primary nameserver: $_\n";
  }

Here are the most popular types supported:

  CNAME - Returns the records canonical name.
  A - Returns the records address field.
  TXT - Returns the descriptive text.
  MX - Returns name of this mail exchange.
  NS - Returns the domain name of the nameserver.
  PTR - Returns the domain name associated with this record.
  SOA - Returns the domain name of the original or
      nameserver for this zone.

  (The descriptions are right out of the Net::DNS POD.)

See Net::DNS documentation for further information about these
types and a comprehensive list of all available types.

=head2 Fetching all of the fields associated with a given record type.

  tie (%dns, 'Tie::DNS', {'type' => 'SOA'});

  my $dns_ref = $dns{'cnn.com'};
  foreach my $field (keys %{$dns_ref}) {
	print "$field = " . ${$dns_ref}{$field} . "\n";
  }

This code fragment will print all of the SOA fields associated
with cnn.com.

=head2 Caching

The argument 'cache' will cause the DNS results to be cached.  The default
is no caching.  The 'cache' argument is passed through to L<Tie::Cache>.
If L<Tie::Cache> cannot be loaded, caching will be disabled.  Entries
whose DNS TTL has expired will be re-queried automatically.

  tie (%dns, 'Tie::DNS', { cache => 100 });
  print "$dns{'cnn.com'}\n";
  print "$dns{'cnn.com'}\n";  ## cached!

=head2 Getting all/different fields associated with a record

  tie (%dns, 'Tie::DNS', {'all_fields' => 'true'});
  my $dns_ref = $dns{'cnn.com'};
  print $dns_ref->{'ttl'}, "\n";

=head2 Changing various arguments to the tie on the fly

  tie (%dns, 'Tie::DNS', {'type' => 'SOA'});
  print $dns{'cnn.com'} . "\n";

  tied(%dns)->args({'type' => 'A'});
  print $dns{'cnn.com'} . "\n";

This code fragment first does an SOA query for cnn.com, and then
changes the default mode to A queries, and displays that.

=head2 Simple Dynamic Updates

Assign into the hash, key DNS name, value IP address, to add a record
to the zone in the domain argument.  For instance:

  tie (%dns, 'Tie::DNS', {
		'domain' => 'realms.lan',
		'multiple' => 'true'});

  $dns{'food.realms.lan.'} = '131.22.40.1';

  foreach (@{$dns{'food'}}) {
        print " $_\n";
  }

=head1 TODO

This .5 release supports the basic functionality of 
Net::DNS.  The 1.0 release will support the following:

Different access methods for forward and reverse lookups.

The 2.0 release will strive to support DNS security options.

=head1 AUTHOR

Dana M. Diederich <dana@realms.org>

=head1 ACKNOWLEDGMENTS

kevin brintnall <kbrint@rufus.net> for Caching patch

=head1 BUGS

This project is very incomplete.  in-addr.arpa zone transfers aren't 
yet supported.  This module ONLY supports named arguments, not
positional.

Patches, flames, opinions, enhancement ideas are all welcome.

=head1 COPYRIGHT

Copyright (c) 2008, Dana M. Diederich. All Rights Reserved.
This module is free software. It may be used, redistributed
and/or modified under the terms of the Perl Artistic License
  (see http://www.perl.com/perl/misc/Artistic.html)

=cut
