File Coverage

blib/lib/Net/DAS.pm

Criterion	Covered	Total	%
statement	91	116	78.4
branch	36	66	54.5
condition	5	20	25.0
subroutine	14	16	87.5
pod	3	3	100.0
total	149	221	67.4

package Net::DAS;

=pod

=head1 NAME

Net::DAS - Simple Domain Availabilty Seach client.

=head1 SYNOPSIS

  # new object
  my $das = Net::DAS->new();
  # you can change query timeout, set to use registrar DAS servers (where available), select only specific modules, and override the requst function (normally for testing)
  my $das = Net::DAS->new({timeout=>2,use_registrar=>1,modules=>['eu','be'],_request=>\&my_request});

  # lookup() always works in batch mode, so if you are only looking up a single domain you can access that domains result directly
  my $res  =$das->lookup('test.eu')->{'test.eu'};
  if ($res->{'avail'}) {
	  # do something
  } else {
     print $res->{'reason'};
  }

  # or with multiple domains
  my $res  =$das->lookup('test.eu','test2.eu','test3.eu');
  print $res->{'test2.eu'}->{'reason'};

=head1 DESCRIPTION

Net::DAS is a client that aims to simplify using DAS with multiple registries by having small submodules (see L) to iron out the differences in the servers. It also inclused a shell script  L to do lookups from the command line.

=head1 PUBLIC METHODS

=cut

use 5.010;
use strict;
use warnings;
use Carp qw (croak);
use Module::Load;
use IO::Socket::INET;
use Time::HiRes qw (usleep);

our $VERSION = '0.17';
our @modules = qw (EU BE NO LT UK SI IT GENT SE NU);

=pod

=head2 new

Accepts a hash reference with available options being timeout (integer default 4), use_registrar (bool default 0), modules (array_ref default all), _request (sub - only used for overriding request method for testing)

  my $das = Net::DAS->new();
  my $das = Net::DAS->new({timeout=>2,use_registrar=>1,modules=>['eu','be'],_request=>\&my_request});

=cut

sub new {
	my $class = shift;
	my $self = shift || {};
	bless $self, $class;
	$self->{tlds} = {};
	$self->{use_registrar} = undef unless exists $self->{use_registrar};
	$self->{timeout} = 4 unless exists $self->{timeout};
	$self->{_request} = \&_send_request unless exists $self->{_request};
	our (@modules);
	@modules = @{$self->{modules}} if exists $self->{modules};
	my ($m,$t);
	foreach (@modules) {
		$m = 'Net::DAS::'.uc($_);
	    eval {
			load($m);
			$self->{$m} = $m->register();
			foreach my $t (@{$self->{$m}->{tlds}}) {
				$self->{tlds}->{$t} = $m;
			}
		};
	    if ($@) {
			warn "Warning: unable to load module $m: $@\n";
			next;
		}
	}
	return $self;
}

=pod

=head2 lookup

Lookup domain availability in batch mode. You can specify 1 or more domains, but always works in batch mode, so if you are only looking up a single domain you can access that domains result directly by using the domain name as a reference. When looking up multiple domains, just send an array and the return will be a hashref with the domain names as the keys

  my $res  =$das->lookup('test.eu')->{'test.eu'};
  if ($res->{'avail'}) {
	  # do something
  } else {
     print $res->{'reason'};
  }

  # or with multiple domains
  my $res  =$das->lookup('test.eu','test2.eu','test3.eu');
  my $res  =$das->lookup(@domains);
  print $res->{'test2.eu'}->{'reason'};

=cut

sub lookup {
	my ($self,@domains) = @_;
	return { 'avail'=>-1,'reason'=>'NO DOMAIN SPECIFIED' } unless @domains;
	my ($r,$b) = {};
	foreach my $i (@domains)
	{
		chomp($i);
		$r = {'domain' => $i};
		eval {
			($r->{'label'},$r->{'tld'}) = $self->_split_domain($i);
			croak ("TLD ($r->{'tld'}) not supported") unless ($r->{'module'} = $self->{tlds}->{$r->{'tld'}});
			my ($disp) = defined $self->{$r->{module}}->{dispatch} ? $self->{$r->{module}}->{dispatch} : [];
			chomp ($r->{'query'} = defined($disp->[0]) ? $disp->[0]->($r->{'domain'}) : $r->{'domain'});

			local $SIG{ALRM} = sub { die "TIMEOUT\n" };
			alarm $self->{timeout};
			chomp ($r->{'response'} = $self->{_request}->($self,$r->{'query'},$r->{module}));
			alarm 0;

			$r->{'avail'} = defined($disp->[1]) ? $disp->[1]->($r->{'response'},$i) : $self->_parse($r->{'response'},$i);
			$r->{'reason'} = 'AVAILABLE' if $r->{'avail'} == 1;
			$r->{'reason'} = 'NOT AVAILABLE' if $r->{'avail'} == 0;
			$r->{'reason'} = 'NOT VALID' if $r->{'avail'} == -1;
			$r->{'reason'} = 'NOT AUTHORIZED' if $r->{'avail'} == -2;
			$r->{'reason'} = 'IP BLOCKED' if $r->{'avail'} == -3;
			$r->{'reason'} = 'UNABLE TO PARSE RESPONSE' if $r->{'avail'} == -100;
		};
		if ($@) {
			chomp($r->{reason} = $@);
			$r->{avail}=-1;
		}
		$b->{$i} = $r;
	};
	$self->_close_ports();
	return $b;
}

=pod

=head2 available

A quick function to lookup availability of a single domain without details. Warning, you should check if the result == 1, as there are different return codes.

  print "available" if $das->availabile('test.eu')==1;

=cut

sub available {
	my ($self,$dom) = @_;
	my $r = $self->lookup($dom);
	return $r->{$dom}->{'avail'};
}

=pod

=head1 PRIVATE METHODS

=item _split_domain : splits a domain into an array ($dom,$tld)

=cut

sub _split_domain
{
	my ($self,$i) = @_;
	return ($1,$2) if $i =~ m/(.*)\.(.*\..*)/ && exists $self->{tlds}->{$2};
	return ($1,$2) if $i =~ m/(.*)\.(.*)/;
	croak('Invalid domain ' . $i);
	return;
}

=pod

=item _send_request : should not be called directly, its called by lookup()

=cut

sub _send_request {
	my ($self,$q,$m) = @_;
	my $svc = ($self->{use_registrar}  && exists $self->{$m}->{registrar}) ? 'registrar' : 'public';
	my $h = $self->{$m}->{$svc}->{host};
	my $p = defined $self->{$m}->{$svc}->{port} ? $self->{$m}->{public}->{port} : 4343;
	my $pr = defined $self->{$m}->{$svc}->{proto} ? $self->{$m}->{public}->{proto} : 'tcp';
	if (!$self->{$m}->{sock} || !$self->{$m}->{sock}->connected()) {
		$self->{$m}->{sock} = IO::Socket::INET->new(PeerAddr => $h, PeerPort => $p, Proto=> $pr, Timeout => 30) || croak("Unable to connect to $h:$p $@");
	}
	#usleep($self->{$m}->{delay}) if exists $self->{$m}->{delay};
	$self->{$m}->{sock}->syswrite($q."\n");
	my ($res,$buf);
	while ($self->{$m}->{sock}->sysread($buf,1024)) {
		$res .= $buf;
		last if $self->{$m}->{sock}->atmark;
	}
	unless (exists $self->{$m}->{close_cmd}) {
		$self->{$m}->{sock}->close();
		undef $self->{$m}->{sock};
	}
	return $res;
}

=pod

=item _parse : should not be called directly, its called by lookup(). This sub is normally overriden by the registry module's parser

=cut

sub _parse {
	my $self = shift;
	chomp (my $i = uc(shift));
	return -3 if $i =~ m/IP ADDRESS BLOCKED/;
	return 1 if $i =~ m/.*STATUS:\sAVAILABLE/;
	return 0 if $i =~ m/.*STATUS:\sNOT AVAILABLE/;
	return -1 if $i =~ m/.*STATUS:\sNOT VALID/;
	return (-100) ;
}

=pod

=item _close_ports : closes any open sockets; you should'nt need to call this.

=cut

sub _close_ports {
	my $self = shift;
	return unless defined $self->{modules};
	foreach my $k (@{$self->{modules}}) {
		my $m = 'NET::DAS'.$k;
		next unless exists $self->{$m} && !defined $self->{$m}->{sock} && $self->{$m}->{sock}->connected();
		$self->{$m}->{sock}->syswrite($self->{$m}->{close_cmd}) if exists $self->{$m}->{close_cmd};
		undef $self->{$m}->{sock};
	}
	return;
}

=pod

=item DESTROY: ensures that any open sockets are closed cleanly before closing; you dont need to call this.

=cut

sub DESTROY {
	my $self = shift;
	$self->_close_ports() if defined $self->{modules};
	undef $self->{modules};
}

1;

=pod

=head1 AUTHOR

Michael Holloway

=head1 LICENSE

Artistic License

=cut