File Coverage

blib/lib/RPC/PlClient.pm

Criterion	Covered	Total	%
statement	106	109	97.2
branch	27	48	56.2
condition	5	10	50.0
subroutine	16	17	94.1
pod	3	4	75.0
total	157	188	83.5

#   -*- perl -*-
#
#
#   PlRPC - Perl RPC, package for writing simple, RPC like clients and
#       servers
#
#   RPC::PlClient.pm is the module for writing the PlRPC client.
#
#
#   Copyright (c) 1997, 1998  Jochen Wiedmann
#
#   You may distribute under the terms of either the GNU General Public
#   License or the Artistic License, as specified in the Perl README file.
#
#   Author: Jochen Wiedmann
#           Email: jochen.wiedmann at freenet.de
#

use strict;

use RPC::PlClient::Comm ();
use Net::Daemon::Log ();
use IO::Socket ();


package RPC::PlClient;

$RPC::PlClient::VERSION = '0.2020';
@RPC::PlClient::ISA = qw(Net::Daemon::Log);


############################################################################
#
#   Name:    new
#
#   Purpose: Constructor of the PlRPC::Client module
#
#   Inputs:  $self - Class name
#            @attr - Attribute list
#
#   Returns: Client object; dies in case of errors.
#
############################################################################

sub new ($@) {
    my $proto = shift;
    my $self = {@_};
    bless($self, (ref($proto) || $proto));

    my $comm = $self->{'comm'} = RPC::PlClient::Comm->new($self);
    my $app = $self->{'application'}  or
	$self->Fatal("Missing application name");
    my $version = $self->{'version'}  or
	$self->Fatal("Missing version number");
    my $user = $self->{'user'} || '';
    my $password = $self->{'password'} || '';

    my $socket;
    if (!($socket = $self->{'socket'})) {
	$self->Fatal("Missing peer address") unless $self->{'peeraddr'};
	$self->Fatal("Missing peer port")
	    unless ($self->{'peerport'}  ||
		    index($self->{'peeraddr'}, ':') != -1);
	$socket = $self->{'socket'} = IO::Socket::INET->new
	    ('PeerAddr' => $self->{'peeraddr'},
	     'PeerPort' => $self->{'peerport'},
	     'Proto'    => $self->{'socket_proto'},
	     'Type'     => $self->{'socket_type'},
	     'Timeout'  => $self->{'timeout'});
	$self->Fatal("Cannot connect: $!") unless $socket;
    }
    $self->Debug("Connected to %s, port %s",
		 $socket->peerhost(), $socket->peerport());
    $self->Debug("Sending login message: %s, %s, %s, %s",
		 $app, $version, $user, "x" x length($password));
    $comm->Write($socket, [$app, $version, $user, $password]);
    $self->Debug("Waiting for server's response ...");
    my $reply = $comm->Read($socket);
    die "Unexpected EOF from server" unless defined($reply);
    die "Expected server to return an array ref" unless ref($reply) eq 'ARRAY';
    my $msg = defined($reply->[1]) ? $reply->[1] : '';
    die "Refused by server: $msg" unless $reply->[0];
    $self->Debug("Logged in, server replies: $msg");

    return ($self, $msg) if wantarray;
    $self;
}


############################################################################
#
#   Name:    Call
#
#   Purpose: Coerce method located on the server
#
#   Inputs:  $self - client instance
#            $method - method name
#            @args - method attributes
#
#   Returns: method results; dies in case of errors.
#
############################################################################

sub Call ($@) {
    my $self = shift;
    my $socket = $self->{'socket'};
    my $comm = $self->{'comm'};
    $comm->Write($socket, [@_]);
    my $msg = $comm->Read($socket);
    die "Unexpected EOF while waiting for server reply" unless defined($msg);
    die "Server returned error: $$msg" if ref($msg) eq 'SCALAR';
    die "Expected server to return an array ref" unless ref($msg) eq 'ARRAY';
    @$msg;
}

sub ClientObject {
    my $client = shift;  my $class = shift;  my $method = shift;
    my($object) = $client->Call('NewHandle', $class, $method, @_);
    die "Constructor didn't return a TRUE value" unless $object;
    die "Constructor didn't return an object"
	unless $object =~ /^((?:\w+|\:\:)+)=(\w+)/;
    RPC::PlClient::Object->new($1, $client, $object);
}

sub Disconnect {
    my $self = shift;
    $self->{'socket'} = undef;
    1;
}


package RPC::PlClient::Object;

use vars qw($AUTOLOAD);

sub AUTOLOAD {
    my $method = $AUTOLOAD;
    my $index;
    die "Cannot parse method: $method"
	unless ($index = rindex($method, '::')) != -1;
    my $class = substr($method, 0, $index);
    $method = substr($method, $index+2);
    eval <<"EOM";
        package $class;
        sub $method {
            my \$self = shift;
            my \$client = \$self->{'client'}; my \$object = \$self->{'object'};
            my \@result = \$client->Call('CallMethod', \$object, '$method',
					 \@_);
            return \@result if wantarray;
            return \$result[0];
        }
EOM
    goto &$AUTOLOAD;
}

sub new {
    my($class, $cl, $client, $object) = @_;
    $class = ref($class) if ref($class);
    no strict 'refs';
    my $ocl = "${class}::$cl";
    @{"${ocl}::ISA"} = $class unless @{"${ocl}::ISA"};
    my $self = { 'client' => $client, 'object' => $object };

    bless($self, $ocl);
    $self;
}


sub DESTROY {
    my $saved_error = $@; # Save $@
    my $self = shift;
    if (my $client = delete $self->{'client'}) {
	eval { $client->Call('DestroyHandle', $self->{'object'}) };
    }
    $@ = $saved_error;    # Restore $@
}

1;


__END__