File Coverage

blib/lib/IO/Lambda/DNS.pm

Criterion	Covered	Total	%
statement	45	61	73.7
branch	10	28	35.7
condition	5	9	55.5
subroutine	7	8	87.5
pod	2	2	100.0
total	69	108	63.8

# $Id: DNS.pm,v 1.10 2009/08/02 21:24:40 dk Exp $
package IO::Lambda::DNS;
use vars qw($DEBUG $TIMEOUT $RETRIES @ISA);
@ISA = qw(Exporter);
@EXPORT_OK = qw(dns);
%EXPORT_TAGS = ( all => \@EXPORT_OK);
$TIMEOUT = 4.0; # seconds
$RETRIES = 4;   # times

use strict;
use Socket;
use Net::DNS::Resolver;
use IO::Lambda qw(:all);

# given the options, returns new dns lambda
sub new
{
	shift;

	# get the options
	my @ctx;
	my $timeout  = $TIMEOUT;
	my $retries  = $RETRIES;
	my %opt;
	for ( my $i = 0; $i < @_; $i++) {
		if ( $i == 0 or $i == $#_ or not defined($_[$i])) {
			# first or last or undef parameter in no way can be an option
			push @ctx, $_[$i];
		} elsif ( $_[$i] =~ /^(timeout|deadline)$/) {
			$timeout  = $_[++$i];
		} elsif ( $_[$i] eq 'retry') {
			$retries  = $_[++$i];
		} elsif ( $_[$i] =~ /^(
			nameservers|recurse|debug|config_file|
			domain|port|srcaddr|srcport|retrans|
			usevc|stayopen|igntc|defnames|dnsrch|
			persistent_tcp|persistent_udp|dnssec
		)$/x) {
			$opt{$_[$i]} = $_[$i + 1];
			$i++;
		} else {
			push @ctx, $_[$i];
		}
	}

	my $simple_query = (( 1 == @ctx) and not ref($ctx[0]));

	# proceed
lambda {
	my $obj  = Net::DNS::Resolver-> new( %opt);
	my $bg_obj = $obj-> bgsend( @ctx);
	return "send error: " . $obj-> errorstring unless $bg_obj;

	my $sock;
	if ( $Net::DNS::VERSION == 1.03 ) {
		# this is a IO::Select object
		my @handles = $bg_obj->handles;
		if ( 1 != @handles ) {
			warn "There's something wrong with Net::DNS version $Net::DNS::VERSION, please notify the author\n";
			return "panic: Net::DNS returned not 1 socket\n";
		}
		$sock = $handles[0]->[0];
	} else {
		$sock = $bg_obj;
	}

	context $sock, $timeout;
readable {
	unless ( shift) {
		return 'connect timeout' if $retries-- <= 0;
		return this-> start; # restart the whole lambda
	}

	my $err = unpack('i', getsockopt($sock, SOL_SOCKET, SO_ERROR));
	if ( $err) {
		$! = $err;
		return "socket error: $!";
	}
	return again unless $obj-> bgisready($bg_obj);

	my $packet = $obj-> bgread( $bg_obj);
	undef $sock;
	undef $bg_obj;

	return "recv error: " . $obj-> errorstring unless $packet;

	if ( $simple_query) {
		# behave like inet_aton, return single IP address
		for ( $packet-> answer) {
			return $_-> address if $_-> type eq 'A';
		}
		return 'response doesn\'t contain an IP address';
	}

	return $packet;
}}}

sub dns(&) { IO::Lambda::DNS-> new(context)-> condition(shift, \&dns, 'dns') }

1;

__DATA__