File Coverage

blib/lib/Net/DLookup.pm

Criterion	Covered	Total	%
statement	41	167	24.5
branch	12	90	13.3
condition	4	33	12.1
subroutine	7	12	58.3
pod	0	5	0.0
total	64	307	20.8

package Net::DLookup;

=head1 NAME

Net::DLookup - Perform domain lookups on 2-letter and 3-letter TLDs

=head1 SYNOPSIS

     use Net::DLookup;

     # Initialize Net::DLookup object
     my $dlu = Net::DLookup -> new;

     # Replace domain definitions from a file
     $dlu -> LoadTLD($file, 1);

     # Add domain definitions from a file
     $dlu -> LoadTLD($file, 0);

     # Check domain name validity and assign it to the object
     @errors = $dlu -> IsValid($domain);

     # Return availability
     @response = $dlu -> DoWhois(0);

     # Return availability and registrar information
     @response = $dlu -> DoWhois(1);


=head1 DESCRIPTION

Net::DLookup performs domain lookups for 2-letter and 3-letter top level domains.  It also verifies the validity of
domain names by checking punctuation, length, metacharacters, etc..

Information for currently recognized top level domains is included within the module. This list may be replaced or
added to by calling $dlu->LoadTLD().

With the advent of new registrars for 3-letter top level domains, it's become difficult to get the
whois output from a single domain lookup, unless you know what registration agency to look at.  Net::DLookup solves
this problem by checking Internic's database first and then performing a second query to the respective registrar
for full whois output.


=head1 USAGE

These functions must be used in order:

Of course:

     use Net::DLookup;

Create an object that contains the default top level domains.

     my $dlu = Net::DLookup -> new;

Validate domain name ($domaintocheck) and associate it with the object.
This must be the full domain name, such as yourdomain.com.

     my @errors = $dlu -> IsValid($domaintocheck);

It checks for the following possible errors:

=over 4

=item Is 67 characters or less for 3-letter TLDs

=item Is not a 3rd level domain for 3-letter TLDs (me.yourdomain.com)

=item Is 26 characters or less for 2-letter TLDs

=item Is not a 4th level domain for 2-letter TLDs (me.yourdomain.co.uk)

=item Does not start or end with a non-alphanumeric character

=item Does not contain non alphanumeric characters (except a dash) within the domain name

=item Is a valid TLD*

=back

* All CCTLDs (Country Code TLDs) currently listed at IANA as well as the .com, .net, .org, .edu and .mil are checked

@errors will contain a list of all possible errors that the domain name may have, such as:

=over 4

=item Domain name can't start or end with non-alphanumeric character.

=item Domains with the .com extension cannot exceed 67 characters.

=back

Last, the domain lookup.

     @response = $domain->Net::DLookup::DoWhois();

=over 4 @response will contain (in order)

=item Is domain registered?   1 for yes; 0 for no

=item Name of Registration Agency or Country

=item URL of Registration Agency for TLD

=item Whois Server for TLD

=item Whois Output

=item A "worded" reponse for domain availability "{domain} is available"

=back

If you're looking up a 3-letter TLD domain (.com, .net, .org, .edu and .mil), you have the choice to NOT perform
the second lookup.  This would be useful if you're just checking for domain availability and don't care who's
already registered it.  You can disable the second lookup by removing the 1.  This will give you Internic's
plain Jane, uninformative whois information.

     @response = $domain->Net::DLookup::DoWhois(1);

=cut


=head1 RESTRICTIONS

Net::DLookup requires that the Sockets (included with the Perl distribution) module is installed.

=head1 VERSION

Net::DLookup Version 1.01  6/10/2000

=head1 CAVEATS

Registration agencies are finicky beasts.  They may change their whois server, urls, or responses (that this module
relies on) without notice.  As of 6/10/2000, the agency data in the module is accurate.

=head1 CREDITS

Many thanks goes to Michael Chase for the new LoadTLD() and DumpTLD() routines.

=head1 AUTHOR

D. Jasmine Merced  , CPAN ID: DJASMINE

The Perl Archive

=head1 COPYRIGHT

This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
If you make modifications, the author would like to know so that they can be incorporated into future releases.

=cut


use strict;
use vars qw( $VERSION %_tld_data );
$VERSION = '1.01';

use Exporter;
my @ISA = qw( Exporter );

# Initialize class level data
my ( $MAX2TLD, $MAX3TLD, @ERRORS ) = ( 26, 67 );

sub new {
    my $class = ref $_[0] || $_[0];

    my $dlu = bless {
	_TLD_DATA      	=>	undef,

	_FULLDOMAIN	=>	$_[1],
	_NAME		=>	undef,
	_TLD		=>	undef,
	_NATION		=>	undef,

	_ISVALID	=>	undef,
	_RESPONSE	=>	undef,
	_WHOISOUTPUT	=>	undef,
	_ISREGISTERED	=>	undef,

	_TLDNAME	=>	undef,
	_TLDURL		=>	undef,
	_TLDMATCHRESP	=>	undef,
	_TLDQUERYDB	=>	undef,

	ERROR		=>	undef,

    }, $class;

    $dlu -> LoadTLD( $_[1], 1 );
    return $dlu;
}

sub LoadTLD {
	my ( $dlu, $file, $clear ) = @_;
	my $oldfile = '';
	my ( $TLD, $URL, $QUERYDB, $MATCHRESP, $NAME );

	$dlu -> {_TLD_DATA} = {} if $clear || ! $dlu -> {_TLD_DATA};

	if ( $file ) {
		if ( ! ref $file ) {
			open( FILE, "<$file" ) or die "Can't read from $file, $!";
			$oldfile = $file;
			$file = \*FILE;
		}
		while ( <$file> ) {
			s/\s+$//;
			next if '' eq $_ || /^\s*#/;
			( $TLD, $URL, $QUERYDB, $MATCHRESP, $NAME ) = split(/\t/,$_);
			foreach ( $TLD, $URL, $QUERYDB, $MATCHRESP, $NAME ) {
				$_ = '' if ! defined $_;
			}
			${$dlu -> {_TLD_DATA}}{$TLD} = [ $URL, $QUERYDB, $MATCHRESP, $NAME ];
		}
		close $file if $oldfile;
	}
	if ( ! keys %{$dlu -> {_TLD_DATA}} ) {
		my $start = tell DATA;
		$dlu -> LoadTLD( \*DATA, 1 );
		seek DATA, $start, 0;
	}
}

sub DumpTLD {
	my ( $dlu, $file ) = @_;
	return if ! $file || ! $dlu -> {_TLD_DATA};
	my ( $oldfile, $TLD, $line, @dom );

	if ( ! ref $file ) {
		open( FILE, ">$file" ) or die "Can't write to $file, $!";
		$oldfile = $file;
		$file = \*FILE;
	}
	foreach $TLD (
		# Sort domains by most general part first
		map { @dom = split /\t/, $_; join ".",  reverse @dom }
		sort
		map { @dom = split /\./, $_; join "\t", reverse @dom }
		keys %{$dlu -> {_TLD_DATA}}
	){
		$line = join "\t", $TLD, @{$dlu -> {_TLD_DATA}{$TLD}};
		$line =~ s/\s+$//;
		print $file "$line\n";
	}
	close $file if $oldfile;
}


sub IsValid {
	my ($self,$domain) = @_;
	@ERRORS = ();
	unless ($domain){
		push(@ERRORS,"Error.  No domain has been entered.\n");
	}
	else {
		$self->{_FULLDOMAIN} = $domain;
		my @DOMAIN = ();
		@DOMAIN = split(/\./,$self->{_FULLDOMAIN});
		my @REVERSED = reverse @DOMAIN;

		if($DOMAIN[3]){
			push(@ERRORS,"Error.  Fourth level domains are not acceptable.\n")
		}
		elsif ($DOMAIN[2]){
			if(length($REVERSED[0])==2){
				$self->{_TLD} = $REVERSED[1].'.'.$REVERSED[0];
				$self->{_NAME} = $REVERSED[2];
			}
			else {
				push(@ERRORS,"This program cannot handle 3rd level domains.\n");
			}
		}
		else {
			$self->{_TLD} = $REVERSED[0];
			$self->{_NAME} = $REVERSED[1];
		}

		if (($self->{_TLD})&&($self->{_NAME})){
			_GetRegistrar($self);
			_ValidateName($self);
		}
		else {
			push(@ERRORS,"Error.  Invalid domain name.\n");
		}

	}
	return @ERRORS;
}

sub DoWhois {
	my $self = shift;
	my $INTERNICWHOIS = shift;
	my ($ATTEMPTS,$MAXTRIES) = "";

	unless ($self->{TLDQUERYDB}){
		_GetRegistrar($self);
	}

	if ($self->{_TLDQUERYDB}){

		my (@RESULT) = _PerformWhois($self);
		foreach(@RESULT){
			$self->{_WHOISOUTPUT} .= $_;
		}

		$self->{_ISREGISTERED} = 1;

		$self->{_RESPONSE} = "$self->{_FULLDOMAIN} is already registered.\n";

		if ($self->{_WHOISOUTPUT} =~ /$self->{_TLDMATCHRESP}/mig){
			$self->{_ISREGISTERED} = 0;
			$self->{_RESPONSE} = "$self->{_FULLDOMAIN} is available for registration.";
		}
		elsif ($self->{_WHOISOUTPUT} =~ /^\*/mig) {
			$ATTEMPTS++;
			sleep(1);
			if ($ATTEMPTS > $MAXTRIES) {
				$self->{_RESPONSE} = "Internic's Whois database is unavailable.";
			}
		}
		elsif ($self->{_RESPONSE} =~ /$!/g) {
			$self->{_RESPONSE} = "Could not connect to whois server $self->{_TLDQUERYDB}: $!";
		}

		if (($self->{_ISREGISTERED}==1)&&(length($self->{_TLD})==3)){
			foreach(@RESULT){
				chomp;
				if (/Registrar: /){
					$self->{_TLDNAME} = (split(/Registrar: /,$_))[1];
				}
				if (/Whois Server\: /){
					$self->{_TLDQUERYDB} = (split(/Whois Server: /,$_))[1];
				}
				if (/Referral URL: /){
					$self->{_TLDURL} = (split(/Referral URL: /,$_))[1];
				}
			}
		}
		if($INTERNICWHOIS){
			@RESULT = _PerformWhois($self);
			if (@RESULT){$self->{_WHOISOUTPUT}=undef;}
			foreach(@RESULT){
				$self->{_WHOISOUTPUT} .= $_;
			}
		}
	}
	else {
		$self->{_RESPONSE} = "$self->{_TLD} does not have a whois server to look up. ";
		$self->{_RESPONSE} .= "More information can be found at $self->{_TLDURL}" if $self->{_TLDURL};
	}

	return ($self->{_ISREGISTERED},$self->{_TLDNAME},$self->{_TLDURL},$self->{_TLDQUERYDB},$self->{_WHOISOUTPUT},$self->{_RESPONSE},$self->{_TLD});
}

sub _ValidateName {
	my $self = shift;

	my $tldlength 		= length($self->{_TLD});
	my $domlength 		= length($self->{_FULLDOMAIN});
	my $strip_dashes 	= $self->{_NAME};
	my $temptest 		= $self->{_TLD};
	my @tippytoptld 	= split(/\./,$self->{_TLD});

	unless($tippytoptld[1]){
		$tippytoptld[1] = $tippytoptld[0];
	}

	$strip_dashes =~ s/(-||\.)//g;

	# Check TLD length
	if (($tldlength > 6)||($tldlength <2)){
		push(@ERRORS,"Invalid TLD.\n")
	}

	# Check fully qualified domain name length
	if ((length($tippytoptld[1]) == 2)&&($domlength > $MAX2TLD)){
		push(@ERRORS,"Domains with the $self->{_TLD} extension cannot exceed $MAX2TLD characters.\n");
	}
	elsif ((length($tippytoptld[1]) == 3)&&($domlength > $MAX3TLD)){
		push(@ERRORS,"Domains with the $self->{_TLD} extension cannot exceed $MAX3TLD characters.\n");
	}

	# Check dash placement
	if (($self->{_NAME} =~ /^\W/)||($self->{_NAME} =~ /\W$/)){
		push(@ERRORS,"Domain name can't start or end with non-alphanumeric character.\n");
	}

	# Check for invalid characters
	if ($strip_dashes =~ /\W/){
		push(@ERRORS,"Invalid characters in domain name $strip_dashes.\n");
	}

}


sub _GetRegistrar {
	my $self = shift;

	$self -> LoadTLD( '', 1 ) if ! keys %{$self -> {_TLD_DATA}};

	my $TLD = '';
	if    ( exists $self -> {_TLD_DATA}{$self -> {_TLD}} ) {
		$TLD = $self -> {_TLD};
	}
	elsif ( exists $self -> {_NATION} &&
		exists $self -> {_TLD_DATA}{$self -> {_NATION}} ) {
		$TLD = $self -> {_NATION};
	}

	if ( $TLD ) {
		my ( $URL, $QUERYDB, $MATCHRESP, $NAME ) = @{$self -> {_TLD_DATA}{$TLD}};
		$self -> {_TLDNAME}		= $NAME;
		$self -> {_TLDURL}		= $URL;
		$self -> {_TLDMATCHRESP}	= $MATCHRESP;
		$self -> {_TLDQUERYDB}		= $QUERYDB;
	}

	unless ($self->{_TLDNAME}){
		push @ERRORS, ".$self->{_TLD} is not a valid top level domain.\n";
	}

}

sub _PerformWhois {
	my $self = shift;
	my(@RESULT,$SIN,$LEN,$OFFSET,$WRITTEN,$BUFFER) = "";
	return "No whois server for $self->{_TLD}" if ! $self->{_TLDQUERYDB};
	my ( $whois, $opts ) = ( $self->{_TLDQUERYDB}, '' );
	( $whois, $opts ) = split /\s+/, $whois, 2 if $whois =~ /\s/;
	use Socket;
	socket(SOCK, PF_INET, SOCK_STREAM, (getprotobyname('tcp'))[2]) || return ((""));

	$SIN = sockaddr_in(43, inet_aton( $whois ));
	connect(SOCK, $SIN) || return (("$!"));
	$OFFSET = 0;
	$BUFFER = $self->{_FULLDOMAIN} . "$opts\r\n";
	$LEN = length($BUFFER);
	while($LEN) {
		$WRITTEN = syswrite(SOCK,$BUFFER,$LEN,$OFFSET);
		$LEN -= $WRITTEN;
		$OFFSET += $WRITTEN;
	}

	@RESULT=;
	close(SOCK);
	return @RESULT;
}

1;


__DATA__