Net::Whois::RegistryFusion - perform cacheable whois lookups using RegistryFusion XML API

    $rf = Net::Whois::RegistryFusion->new();
    # OR:
    $rf = Net::Whois::RegistryFusion->new({ refreshCache=>1, 
                                            AUTH=>'http://hexillion.com/rf/xml/1.0/auth/',
                                            WHOIS=>'http://hexillion.com/rf/xml/1.0/whois/'
                                          });
    $rf->isCached('domain.com') 
    && 
    $xml = $rf->whois('domain.com');

 Date::Format (any)
 Error (any)
 File::Slurp (any)
 File::stat (any)
 IO::LockedFile (any)
 LWP::Simple (any)
 Module::Signature (any)
 Set::Array (any)
 Test::More (any)
 Test::Signature (any)

package Net::Whois::RegistryFusion;

use strict;

use LWP::Simple;
use File::Slurp (); # don't import File::Slurp symbols to avoid collisions and reduce overhead
use File::stat;
use IO::LockedFile;
use Date::Format;
use Set::Array;
use Error;

use constant AUTH       => 'http://whois.RegistryFusion.com/rf/xml/1.0/auth/';
use constant WHOIS      => 'http://whois.RegistryFusion.com/rf/xml/1.0/whois/';

use constant TRUE       => 1;
use constant FALSE      => 0;

use vars qw($VERSION);
$VERSION = '0.05';


use fields qw(sessionKey fetchedDomains refreshCache AUTH WHOIS);

sub new {
    my ($self, $opts) = @_;

    $self = fields::new($self) unless ref $self;

    $self->{'fetchedDomains'}   = new Set::Array;
    $self->{'refreshCache'}     = $opts->{'refreshCache'} || FALSE;
    $self->{'AUTH'}             = $opts->{'AUTH'} || AUTH;
    $self->{'WHOIS'}            = $opts->{'WHOIS'} || WHOIS;
    $self->{'sessionKey'}       = $self->_login();
    return $self;
}

sub _login {
    my ($self) = @_;

    if ( defined $self->{'sessionKey'} ) {
        # already logged in
        return;
    }
    my $url = $self->{AUTH} . "?username=" . $self->_getUsername() . "&password=" . $self->_getPassword();
    my $xml = get($url)
        or throw Error::Simple("failed to get $url");
    $xml =~ m#<SessionKey>(.*)</SessionKey>#
        or throw Error::Simple("Couldn't open session");
    return $1;
}

sub logout {
    my ($self) = @_;

    my $url = $self->{AUTH} . "?sessionkey=" . $self->getSessionKey();
    get($url);
}

sub _getUsername {
    throw Error::Simple("this is an abstract method and must be implemented by subclass");
}

sub _getPassword {
    throw Error::Simple("this is an abstract method and must be implemented by subclass");
}

sub _getXmlpath {
    throw Error::Simple("this is an abstract method and must be implemented by subclass");
}

sub getSessionKey {
    my ($self) = @_;
    return $self->{'sessionKey'};
}

sub whois {
    my ($self, $domain) = @_;

    my $xml;
    if ( $self->isCached($domain) ) {
        if ( $self->{refreshCache} ) {
            $self->deleteFromCache($domain);
            $xml = $self->_whois($domain);
        }
        else {
            $xml = $self->_getCached($domain);
        }
    }
    else {
        $xml = $self->_whois($domain);
    }
    return $xml;
}

sub _whois {
# here we do the actual whois lookup
    my ($self, $domain) = @_;

    my $url = $self->{WHOIS} . "?sessionkey=". $self->getSessionKey() . "&query=$domain";
    my $xml = get($url)
        or throw Error::Simple("get $url failed");

# record the domain as fetched for reporting purposes
    $self->{fetchedDomains}->push($domain);
# cache the xml
    $self->_cache($xml, $domain);

    return $xml;
}

sub getFetchedDomains {
    my ($self) = @_;

    return wantarray ? @{ $self->{fetchedDomains} } : $self->{fetchedDomains};
}

sub _getFilename {
    my ($self, $domain) = @_;

    unless ( $domain ) {
        throw Error::Simple("_getFilename called without domain argument");
    }

    my $subdir = lc(substr($domain, 0, 1));
    my $filename = $self->_getXmlpath() . "/$subdir/$domain.xml";

    return wantarray ? ($filename, $subdir) : $filename;
}

sub getCacheDate {
    my ($self, $domain) = @_;

    my $stat = stat($self->_getFilename($domain));
    return time2str("%x", $stat->mtime());
}

sub isCached {
    my ($self, $domain) = @_;
 
    if ( -e $self->_getFilename($domain) ) {
        return TRUE;
    }
    else {
        return FALSE;
    }
}

sub _getCached {
    my ($self, $domain) = @_;

    my $filename = $self->_getFilename($domain);
    my $file = new IO::LockedFile $filename;
    if ( my $xml = File::Slurp::read_file($file) ) { #YYY: Perl6::Slurp is nicer but requires perl5.8+
        return $xml;
    }
}

sub _cache {
    my ($self, $xml, $domain) = @_;
    
    my ($filename, $subdir) = $self->_getFilename($domain);
    $subdir = $self->_getXmlpath() . "/$subdir";
    mkdir $subdir if ! -d $subdir;
    my $file = new IO::LockedFile ">$filename";
    File::Slurp::write_file($file, $xml);
}

sub deleteFromCache {
    my ($self, $domain) = @_;

    my $filename = $self->_getFilename($domain);
    if ( -e $filename ) {
        unlink $filename 
            or throw Error::Simple("Failed to unlink $filename. $!");
    }
}

sub DESTROY {
    my ($self) = @_;
    $self->logout();
}

1;

__END__