File Coverage

blib/lib/Net/Starnet/DataAccounting.pm

Criterion	Covered	Total	%
statement	90	117	76.9
branch	12	26	46.1
condition	8	24	33.3
subroutine	23	28	82.1
pod	5	5	100.0
total	138	200	69.0

package Net::Starnet::DataAccounting;

=head1 NAME

Net::Starnet::DataAccounting - interface to the SDA protocol

=head1 SYNOPSIS

    use constant SDA_UPDATE_TIME 60;
    my $sda = Net::Starnet::DataAccounting->new(
	user => $user,
	pass => $pass,
	verbose => $VERBOSE,
	login  => \&login,
	logout => \&logout,
	update => \&update,
	(defined($hostname) ? ( host => $hostname ) : ()),
	(defined($server) ? ( server => $server ) : ()),
    );
    my $connected = $sda->login();
    if ($connected)
    {
	$SIG{INT} = $SIG{TERM} = sub {
	    $sda->logout();
	    exit 0;
	};
	while ($connected)
	{
	    sleep SDA_UPDATE_TIME;
	    $connected = $sda->update();
	}
	my $disconnected = $sda->logout();
    }

=head1 DESCRIPTION

The Net::Starnet::DataAccounting module provides an interface to the
protocol used by the Starnet Data Accounting System. It allows simple
login, logout and health checking.

=cut

use 5.006001;
use strict;
use warnings;

use Carp;
use Socket;
use IO::Socket;
$|++;

use constant DEBUG => 0;
use constant SDA_HOST => '150.203.223.8:8000';

use constant SDA_LOGIN  => 1;
use constant SDA_LOGOUT => 2;
use constant SDA_UPDATE => 3;

use constant SDA_LOGIN_YES  => 1;
use constant SDA_LOGIN_NO  => 0;
use constant SDA_LOGIN_INCORRECT_USERPASS => 1;
use constant SDA_LOGIN_NO_QUOTA           => 3;
use constant SDA_LOGIN_ALREADY_CONNECTED  => 4;

use constant SDA_UPDATE_YES => 1;
use constant SDA_UPDATE_NO  => 0;

use constant SDA_UPDATE_TIME => 60;

our @ISA = qw//;
our ( $VERSION ) = '$Revision: 1.2 $ ' =~ /\$Revision:\s+([^\s]+)/;

my %defaults = (
    server	=> '150.203.223.8',
    port	=> '8000',
    client	=> "Spoon-v$VERSION",
);


# ========================================================================
#                                                                  Methods

=head1 METHODS

=over 4

=item Net::Starnet::DataAccounting->new(

    host    => $yourhostname,
    server  => $remotehostname,
    port    => $remoteport,
    user    => $username,
    pass    => $password,
    client  => $clientname,
    login   => \&login,
    logout  => \&logout,
    update  => \&update,
    verbose => $verbose,
    )

Creates a new SDA connection. Host and server should be either IPs or
hostnames. Port is a port number, user and pass are the appropriate
username and password. Client is a custom client string for the
connection to use.

Login, logout and update are routines that will be called after an
attempt to send the appropriate message. The routines in question will
be passed two parameters: the SDA object and the text response from the
server (decoded).

Verbose determines whether debugging information will be shown.

=cut

sub new
{
    my $class = shift;
    $class = ref($class) || $class;

    my %opts = @_;

    my $hostname;
    if (exists $opts{host})
    {
	$hostname = $opts{host};
    }
    else
    {
	$hostname = eval
	{
	    require Sys::Hostname;
	    Sys::Hostname::hostname();
	};
    }
    my $ip = gethostbyname($hostname) or die "Couldn't resolve $hostname.\n";
    $ip = join('.', unpack('C4', $ip));

    my $server = $opts{server} || $defaults{server};
    die "Invalid server name.\n" unless (defined $server and length $server);
    $server = gethostbyname($server) or die "Couldn't resolve $server.\n";
    $server = join('.', unpack('C4', $server));

    my $port = $opts{port} || $defaults{port};
    die "Invalid port number.\n" unless ($port < 65536 and $port > 0);

    die "Invalid username.\n" unless (defined $opts{user} and $opts{user} =~ /^\w+$/);
    die "Invalid password.\n" unless (defined $opts{pass} and $opts{pass} =~ /^\d+$/);

    my $self = bless {
	host	=> $ip,
	server	=> $server,
	port	=> $port,
	client  => $opts{client} || $defaults{client},
	login	=> $opts{login},
	logout	=> $opts{logout},
	update	=> $opts{update},
	user	=> $opts{user},
	pass	=> $opts{pass},
	verbose => $opts{verbose} ? 1 : 0,
    }, $class;


    return $self;
}

=item $sda->verbose($value|)

If given a parameter, sets the verbosity. Returns the verbosity in all
cases.

=cut

sub verbose
{
    my $self = shift;
    $self->{verbose} = $_[0] ? 1 : 0 if (@_);
    return $self->{verbose};
}

=item $sda->login()

Directs the SDA object to attempt to connect to the server. Calls the
login routine specified on construction after the attempt is made.

=cut

sub login
{
    my $self = shift;
    my $response = $self->_sda_send(SDA_LOGIN);
    $self->{login}($self,$response);
}

=item $sda->logout()

Directs the SDA object to attempt to disconnect to the server. Calls the
logout routine specified on construction after the attempt is made.

=cut

sub logout
{
    my $self = shift;
    my $response = $self->_sda_send(SDA_LOGOUT);
    $self->{logout}($self,$response);
}

=item $sda->update()

Directs the SDA object to attempt to update the client's status on the
server. Calls the update routine specified on construction after the
attempt is made. This function should be called every two minutes or so;
ideally more frequently.

=cut

sub update
{
    my $self = shift;
    my $response = $self->_sda_send(SDA_UPDATE);
    $self->{update}($self,$response);
}

=back

=cut

# ========================================================================
#                                                                  Private

=begin private

=head1 PRIVATE METHODS

=over 4

=cut

# ------------------------------------------------------------------------
#                                                         SDA Server stuff
# ------------------------------------------------------------------------

=item $sock = $sda->_sda_connect()

Connects to the object's server on the given port and returns the
socket.

=cut

sub _sda_connect
{
    my $self = shift;
    my ($host,$port) = @{$self}{qw/server port/};
    my $sock = IO::Socket::INET->new
	(
	 PeerAddr => $host,
	 PeerPort => $port,
	 Proto => 'tcp',
	 Type => SOCK_STREAM
	) or die "Couldn't connect to $host:$port: $@\n";

    return $sock;
}

=item $result = $sda->_sda_send(ACTION)

Where ACTION is one of SDA_UPDATE, SDA_LOGIN, SDA_LOGOUT.

Sends an appropriately encoded message to the server (does the
connection by calling _sda_connect()), waits for a response and returns
the result (decoded).

=cut

sub _sda_send
{
    my ($self, $number) = @_;
    my $sock = $self->_sda_connect();
    my ($user, $pass, $ip, $client) = @{$self}{qw/user pass host client/};
    my $line = "$number $user $pass $ip 0 $client \n";
    print ">$line" if DEBUG or $self->verbose;
    print $sock ''._encode($line);
    my $response = <$sock>;
    $response = _decode($response);
    print "<$response\n" if DEBUG or $self->verbose;
    $sock->close;
    return $response;
}

# ------------------------------------------------------------------------
#                                                         Generic Routines
# ------------------------------------------------------------------------

=item $encoded = _encode($plain)

Encodes $plain according to the SDA encoding method.

=cut

sub _encode
{
    my $i = 0;
    my ($s) = (@_);
    $s =~ s/(.)/chr ord($1)+$i++%7/eg;
    return $s;
}

=item $plain = _decode($encoded)

Decodes $plain according to the SDA encoding method.

=cut

sub _decode
{
    my $i = 0;
    my ($s) = (@_);
    $s =~ s/(.)/chr ord($1)-$i++%7/eg;
    return $s;
}

=back

=end private

=cut

1;
__END__