File Coverage

blib/lib/RPC/pClient.pm

Criterion	Covered	Total	%
statement	100	153	65.3
branch	32	72	44.4
condition	5	12	41.6
subroutine	15	16	93.7
pod	4	5	80.0
total	156	258	60.4

#   -*- perl -*-
#
#
#   pRPC - Perl RPC, package for writing simple, RPC like clients and
#       servers
#
#   RPC::pClient.pm is the module for writing the pRPC client.
#
#
#   Copyright (c) 1997  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
#           Am Eisteich 9
#           72555 Metzingen
#           Germany
#
#           Email: [e-mail]
#           Phone: [phone]
#
#
#   $Id: pClient.pm,v 0.1001 1997/09/14 22:53:27 joe Exp $
#
package RPC::pClient;

use strict;
use Carp;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);

require Exporter;
require DynaLoader;

@ISA = qw(Exporter DynaLoader);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
@EXPORT = qw(

);
$VERSION = '0.1002';

use POSIX();
use Sys::Syslog();
use IO::Socket();
use Storable();
use Socket();


sub error ($) { my $self = shift; $self->{'error'}; }


############################################################################
#
#   Name:    new
#
#   Purpose: Constructor of the pRPC::Client module
#
#   Inputs:  Hash list of attributes; see pRPC::Client(3)
#
#   Returns: connection object or error message
#
############################################################################

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

    bless($self, $class);

    if (!defined($self->{'application'})  ||  !defined($self->{'version'})) {
	return "Required attributes 'application' or 'version' missing.";
    }

    #
    #   Create Storable objects and send the login message.
    #
    if ($self->_HaveOoStorable) {
	$self->{'io'} = Storable->new('file' => *{$self->{'sock'}}{IO},
				      'crypt' => $self->{'cipher'},
				      'netorder' => 1,
				      'forgive_me' => 1);
	if (!defined($self->{'io'})) {
	    return "Cannot create Storable object: $!";
	}
    } else {
	$self->{'file'} = $self->{'sock'};
    }

    if ($self->{'debug'}) {
        Sys::Syslog::syslog('debug', "Sending login message: %s %s %s",
			    $self->{'application'}, $self->{'version'},
			    $self->{'user'});
    }
    if (!$self->_Store([$self->{'application'},
			$self->{'version'},
			$self->{'user'},
			$self->{'password'}])) {
	return "Cannot send login message: " . $self->{'error'};
    }

    if ($self->{'debug'}) {
        Sys::Syslog::syslog('debug', "Waiting for server's response ...");
    }
    my ($msg) = $self->_Retrieve();
    if (!$msg) {
	$msg = "Error while reading server reply: " . $self->{'error'};
        Sys::Syslog::syslog('debug', $msg);
	return $msg;
    }
    if (ref($msg) ne 'ARRAY') {
	$msg = "Error while reading server reply: Expected array";
        Sys::Syslog::syslog('debug', $msg);
	return $msg;
    }

    if (!$$msg[0]) {
	$msg = "Refused by server: "
	    . (defined($$msg[1]) ? $$msg[1] : "No cause");
        Sys::Syslog::syslog('debug', $msg);
	return $msg;
    }

    Sys::Syslog::syslog('debug', "Logged in, server replies %s",
			defined($$msg[1]) ? $$msg[1] : "undef");
    $self->{'error'} = '';
    $self;
}


############################################################################
#
#   Name:    Call, CallInt
#
#   Purpose: coerce method located on the server
#
#   Inputs:  $con - connection attributes
#            $method - method name
#            @args - method attributes
#
#   Returns: method results; you *must* check $con->error for potential
#            error conditions
#
############################################################################

sub CallInt ($@) {
    my($self) = shift;
    my($error, $msg, @result);

    if (!$self->_Store([@_])) {
	$error = $self->{'error'};
    } else {
	$msg = $self->_Retrieve();
	if (!$msg) {
	    $error = $self->{'error'};
	} elsif (ref($msg) ne 'ARRAY') {
	    $error = "Error while reading server reply: Expected array";
	} elsif (!defined($$msg[0])  ||  !$$msg[0]) {
	    if (defined($$msg[1])  &&  $$msg[1] ne '') {
		$error = $$msg[1];
	    } else {
		$error = "No error message";
	    }
	} else {
	    $error = '';
	    @result = @$msg;
	}
    }

    if ($self->{'error'} = $error) {
	@result = (0, $error);
    }

    if ($self->{'debug'}) {
	if ($self->error) {
	    Sys::Syslog::syslog('err', "Calling method %s -> error %s",
				$_[0], $self->error);
	} else {
	    Sys::Syslog::syslog('debug', "Calling method %s -> ok",
				$_[0]);
	}
    }

    @result;
}

sub Call ($@) {
    my($self) = shift;
    my(@result) = $self->CallInt(@_);

    if (!shift @result) {
	@result = ();
    }

    @result;
}


############################################################################
#
#   Name:    Encrypt
#
#   Purpose: Get or set the current encryption mode
#
#   Inputs:  $self - client object
#            $crypt - encryption object
#
#   Returns: current encryption object; 'undef' for no encryption
#
############################################################################

sub Encrypt ($;$) {
    my ($self, $crypt) = @_;
    if (@_ == 2) {
	if ($self->_HaveOoStorable) {
	    $self->{'io'}->{'crypt'} = $crypt;
	} else {
	    $self->{'cipher'} = $crypt;
	}
    }
    $self->_HaveOoStorable ? $self->{'io'}->{'crypt'} : $self->{'cipher'};
}


############################################################################
#
#   Name:    _Store, _Retrieve
#
#   Purpose: Preliminary replacements for Storable->Store and
#            Storable->Retrieve as long as Raphael hasn't integrated
#            my suggestion for an OO API.
#
#   Inputs:  $self - server object
#            $msg - message being sent (_Store only)
#
#   Returns: _Retrieve returns a message in case of success. Both
#            methods return FALSE in case of error, $self->{'error'}
#            will be set in that case.
#
############################################################################

$RPC::pClient::haveOoStorable = undef;
sub _HaveOoStorable () {
    if (!defined($RPC::pClient::haveOoStorable)) {
	$@ = '';
	eval "Storable->new()";
	$RPC::pClient::haveOoStorable = $@ ? 0 : 1;
    }
    $RPC::pClient::haveOoStorable;
}

sub _Retrieve($) {
    my($self) = @_;
    my($result);

    if ($self->_HaveOoStorable) {
	if (!($result = $self->{'io'}->Retrieve())) {
	    $self->{'error'} = $self->{'io'}->errstr;
	}
	return $result;
    }

    my($encodedSize, $readSize, $blockSize);
    $readSize = 4;
    $encodedSize = '';
    while ($readSize > 0) {
	my $result = $self->{'file'}->read($encodedSize, $readSize,
					   length($encodedSize));
	if ($result < 0) {
	    $self->{'error'} = "Error while reading: $!";
	    return undef;
	}
	$readSize -= $result;
    }
    $encodedSize = unpack("N", $encodedSize);
    $readSize = $encodedSize;
    if ($self->{'cipher'}) {
	$blockSize = $self->{'cipher'}->blocksize;
	if (my $addSize = ($encodedSize % $blockSize)) {
	    $readSize += ($blockSize - $addSize);
	}
    }
    my $msg = '';
    my $rs = $readSize;
    while ($rs > 0) {
	my $result = read($self->{'file'}, $msg, $rs, length($msg));
	if ($result < 0) {
	    $self->{'error'} = "Error while reading: $!";
	    return undef;
	}
	$rs -= $result;
    }
    if ($self->{'cipher'}) {
	my $cipher = $self->{'cipher'};
	my $encodedMsg = $msg;
	$msg = '';
	for (my $i = 0;  $i < $readSize;  $i += $blockSize) {
	    $msg .= $cipher->decrypt(substr($encodedMsg, $i, $blockSize));
	}
	$msg = substr($msg, 0, $encodedSize);
    }
    my $ref = Storable::thaw($msg);
    $ref;
}
sub _Store($$) {
    my($self, $msg) = @_;

    if ($self->_HaveOoStorable) {
	if (!$self->{'io'}->Store($msg)) {
	    $self->{'error'} = $self->{'io'}->errstr;
	    return undef;
	}
	return 1;
    }

    my($encodedMsg) = Storable::nfreeze($msg);
    my($encodedSize) = length($encodedMsg);
    if ($self->{'cipher'}) {
	my $cipher = $self->{'cipher'};
	my $size = $cipher->blocksize;
	if (my $addSize = length($encodedMsg) % $size) {
	    $encodedMsg .= chr(0) x ($size - $addSize);
	}
	$msg = $encodedMsg;
	$encodedMsg = '';
	for (my $i = 0;  $i < length($msg);  $i += $size) {
	    $encodedMsg .= $cipher->encrypt(substr($msg, $i, $size));
	}
    }
    $self->{'file'}->print(pack("N", $encodedSize) . $encodedMsg);
    $self->{'file'}->flush();
}


# Autoload methods go after =cut, and are processed by the autosplit program.

1;
__END__