File Coverage

blib/lib/Net/DNS/Method/Pool.pm

Criterion	Covered	Total	%
statement	77	79	97.4
branch	17	26	65.3
condition	17	38	44.7
subroutine	13	13	100.0
pod	1	4	25.0
total	125	160	78.1

package Net::DNS::Method::Pool;

require 5.005_62;

use Carp;
use Net::DNS;
use NetAddr::IP 3.00;
use Net::DNS::Method;
use vars qw($VERSION @ISA);

@ISA = qw(Net::DNS::Method);

use strict;
use warnings;

$VERSION = '2.00';

				# Default responses
our $DEF_ZONE	= 'some.com';
our $DEF_PREFIX	= 'dyn-';
our $DEF_TTL	= '36000';	# 10 hours

sub new {
    my $type = shift;
    my $class = ref($type) || $type || "Net::DNS::Method::Pool";

    my $ref = shift;

    my $self =
    {
	start => time,
	counter => {},
	zone => (defined($ref) && defined($ref->{BaseDomain}) ?
		 $ref->{BaseDomain} : $DEF_ZONE),
	    prefix => (defined($ref) && defined($ref->{Prefix}) ?
		       $ref->{Prefix} : $DEF_PREFIX),
		ttl => (defined($ref) && defined($ref->{ttl}) ?
			$ref->{ttl} : $DEF_TTL),
		    pool => []
    };

    if (exists $ref->{Pool}) {
	for my $ip (@{$ref->{Pool}}) {
	    my $a = new NetAddr::IP $ip;

	    croak "Address $ip cannot be parsed"
		unless $a;

	    push @{$self->{pool}}, $a;
	}
    }
    else {
	croak
	    "Net::DNS::Method::Pool requires a pool of IP addresses to serve";
    }

    bless $self, $class;
}

sub _parse_ptr ($$) {
    my $self	= shift;
    my $q	= shift;

    if ($q->qname =~ m/^(\d+)\.(\d+)\.(\d+)\.(\d+)\.in-addr\.arpa\.?$/i) {
#	warn "_parse_ptr found $4.$3.$2.$1\n";
	return new NetAddr::IP "$4.$3.$2.$1";
    }

    return undef;
}

sub _parse_a ($$) {
    my $self	= shift;
    my $q	= shift;

    my $name = $q->qname;

#    warn "check on $name\n";

    if (index($name, $self->{prefix}) == 0) {
	substr($name, 0, length($self->{prefix})) = '';
    }
    else { return undef; }

#    warn "match 1 on $name\n";

    if (my $i = index($name, '.' . $self->{zone})) {
	substr($name, $i, length($self->{zone}) + 1) = '';
    }
    else { return undef; }

#    warn "match 2 on $name\n";

    if ($name =~ m/^([0-9]+)-([0-9]+)-([0-9]+)-([0-9]+)$/i
	and $1 >= 0 and $1 <= 255
	and $2 >= 0 and $2 <= 255
	and $3 >= 0 and $3 <= 255
	and $4 >= 0 and $4 <= 255)
    {
#	warn "_parse_a found $1.$2.$3.$4\n";
	return new NetAddr::IP "$1.$2.$3.$4";
    }

    return undef;
}

sub PTR {
    my $self = shift;
    my $q = shift;
    my $ans = shift;

    if (my $a = $self->_parse_ptr($q)) {
	for my $s (@{$self->{pool}}) {
	    if ($s->contains($a)) {
		my $name = $a->addr;
		$name =~ s/\./-/g;
		substr($name, 0, 0) = $self->{prefix};
		$name .= '.';
		$name .= $self->{zone};

		$ans->push('answer', new Net::DNS::RR $q->qname .
			   ' ' . $self->{ttl} . " IN PTR " .
			   $name);
		$ans->header->rcode('NOERROR');
		return NS_OK | NS_STOP;
	    }
	}
    }

    return NS_FAIL;		# No match or error
}

sub A {
    my $self = shift;
    my $q = shift;
    my $ans = shift;

    if (my $a = $self->_parse_a($q)) {
	for my $s (@{$self->{pool}}) {
	    if ($s->contains($a)) {
		$ans->push('answer', new Net::DNS::RR $q->qname .
			   ' ' . $self->{ttl} . " IN A " .
			   $a->addr);
		$ans->header->rcode('NOERROR');
		return NS_OK | NS_STOP;
	    }
	}
    }

    return NS_FAIL;		# No match or error
}

sub ANY { return A(@_ )|| PTR(@_); }

1;
__END__