File Coverage

blib/lib/RPC/pServer.pm

Criterion	Covered	Total	%
statement	138	275	50.1
branch	47	124	37.9
condition	12	35	34.2
subroutine	19	22	86.3
pod	9	12	75.0
total	225	468	48.0

#   -*- perl -*-
#
#
#   pRPC - Perl RPC, package for writing simple, RPC like clients and
#       servers
#
#   RPC::pServer.pm is the module for writing the pRPC server.
#
#
#   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: pServer.pm,v 0.1001 1997/09/14 22:53:27 joe Exp $
#
package RPC::pServer;

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

require Exporter;
require DynaLoader;

@ISA = qw(Exporter DynaLoader RPC::pClient);
# 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.1005';



# Preloaded methods go here.

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


############################################################################
#
#   Name:    _ReadConfigFile
#
#   Purpose: Reads a server configuration file
#
#   Inputs:  file name
#
#   Returns: a reference to a list of clients, if successfull; the
#            reference will additionally be stored in the variable
#            $RPC::pServer::configFile for later use. 'undef'
#            will be returned in case of errors.
#
############################################################################

sub Log($$$@) {
    my($self, $level, $msg, @args) = @_;
    if (!$self->{'stderr'}) {
	Sys::Syslog::syslog($level, $msg, @args);
    } else {
	print STDERR "$msg\n";
    }
}
my $logClass = "RPC::pServer";


sub _ReadConfigFile ($) {
    my($file) = @_;
    my($line, $configFile, $client, $mask, $lineNum);

    if(defined($RPC::pServer::configFile)) {
	return $RPC::pServer::configFile;
    }

    $configFile = [];
    if (!open(FILE, "<$file")) {
	return "Cannot read config file $file: $!";
    }

    $lineNum = 0;
    while (defined($line = )) {
	++$lineNum;
	$line =~ s/\#.*//;   # Comments are allowed
	if ($line =~ /^\s*accept\s+(\S+)\s*$/i) {
	    $mask = $1;
	    $client = { 'mask' => $mask, 'accept' => 1 };
	    push(@$configFile, $client);
	} elsif ($line =~ /^\s*deny\s+(\S+)\s*$/i) {
	    $mask = $1;
	    $client = { 'mask' => $mask, 'accept' => 0 };
	    push(@$configFile, $client);
	} elsif ($line =~ /^\s*(\S+)\s+(.*\S)\s*$/) {
	    if (defined($client)) {
		$client->{$1} = $2;
	    } else {
		close(FILE);
		return "Cannot parse line $lineNum of config file $file.";
	    }
	} elsif ($line !~ /^\s*$/) {
	    close(FILE);
	    return "Cannot parse line $lineNum of config file $file.";
	}
    }

    close(FILE);

    $RPC::pServer::configFile = $configFile;
}


############################################################################
#
#   Name:    new
#
#   Purpose: Constructor of the RPC::pServer module
#
#   Inputs:  Hash list of attributes; see RPC::pServer(3)
#
#   Returns: connection object or 'undef' in case of errors
#
############################################################################

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

    bless($self, $class);

    # Read the configuration file, if not already done.
    if (defined($self->{'configFile'})) {
	my ($result) = _ReadConfigFile($self->{'configFile'});
	if (!ref($result)) {
	    $self->Log('err', $result);
	    return $result;
	}
	$self->{'authorizedClients'} = $result;
    }

    if (!defined($self->{'inetd'})) {
	#   Non-Inetd-Server
	$sock = $self->{'sock'}->accept();
	if (!defined($sock)) {
	    my $msg = "Cannot accept: $?";
	    $self->Log('err', $msg);
	    return $msg;
	}
    } else {
	#   Inetd based server; need to work out how to create a
	#   IO::socket object for that
	$sock = $self->{'sock'};
    }

    #
    #   Check whether the client is authorized to connect
    #
    my ($name, $aliases, $addrtype, $length, @addrs)
	= gethostbyaddr($sock->peeraddr, &Socket::AF_INET);
    my $client;
    foreach $client (@{$self->{'authorizedClients'}}) {
	my($alias, $found, $mask);
	my (@cfl) = (%$client);
	$mask = $client->{'mask'};
	$found = 0;
	if ($sock->peerhost =~ /$mask/  ||
	    $name =~ /$mask/) {
	    $found = 1;
	}
	if (!$found) {
	    foreach $alias (split(/ /, $aliases)) {
		if ($alias =~ /$mask/) {
		    $found = 1;
		    last;
		}
	    }
	}
	if (!$found) {
	    my $addr;
	    foreach $addr (@addrs) {
		if (Socket::inet_ntoa($addr) =~ /$mask/) {
		    $found = 1;
		    last;
		}
	    }
	}
	if ($found) {
	    my ($class, $key);
	    if (!$client->{'accept'}) {
		my $msg = sprintf("Access not permitted from %s, %s",
				  $sock->sockhost, $sock->sockport);
		$self->Log('err', $msg);
		return $msg;
	    }
	    $self->{'client'} = $client;
	    if (defined($key = $client->{'key'})  &&
		defined($class = $client->{'encryption'})) {
		my ($module);
		if (!defined($module = $client->{'encryptModule'})) {
		    $module = $class;
		}
		($self->{'cipher'}) = eval qq{
		    use $module;
		    new $class(pack("H*", \$key));
		};
		$self->Log('debug', "Using encryption: " . $self->{'cipher'});

		if ($@) {
		    my $msg = "Cannot create cipher object: $@";
		    $self->Log('err', $msg);
		    return $msg;
		}
	    }
	    last;
	}
    }
    if ($self->{'configFile'}  &&  !$self->{'client'}) {
	my $msg = sprintf("Access not permitted from %s, %s",
			  $sock->sockhost, $sock->sockport);
	$self->Log('err', $msg);
	return $msg;
    }

    $self->Log('notice', sprintf("Accepting connect from %s, port %s",
				 $sock->sockhost, $sock->sockport));

    #
    #   Ok, the client is allowed to connect. Create Storable
    #   objects and wait for the login message.
    #
    if ($self->_HaveOoStorable) {
	$self->{'io'} = Storable->new('file' => *{$sock}{IO},
				      'crypt' => $self->{'cipher'},
				      'netorder' => 1,
				      'forgive_me' => 1);
	if (!defined($self->{'io'})) {
	    my $msg = "Cannot create Storable object for read: $!";
	    $self->Log('err', $msg);
	    return $msg;
	}
    } else {
	$self->{'file'} = $sock;
    }

    if ($self->{'debug'}) {
	$self->Log('debug', "$logClass: Waiting for client to log in.");
    }

    my $loginMsg;
    $loginMsg = $self->_Retrieve();
    if (!defined($loginMsg)) {
	my $msg = "Error while logging in: " . $self->error;
	$self->Log('err', $msg);
	return $msg;
    }
    if (ref($loginMsg) ne 'ARRAY') {
	my $msg = "Error while logging in: Expected array.";
	$self->Log('err', $msg);
	return $msg;
    }

    ($self->{'application'}, $self->{'version'}, $self->{'user'},
     $self->{'password'}) = @$loginMsg;
    if ($self->{'debug'}) {
	$self->Log('debug', "$logClass: Client logs in: "
		            . $self->{'application'}
		            . " " . $self->{'version'} . " "
		            . ($self->{'user'} || ''));
    }
    if (!defined($self->{'application'})  ||
	!defined($self->{'version'})) {
	my $msg = "Protocol error while logging in";
	$self->Log('err', $msg);
	return $msg;
    }

    $self->{'sock'} = $sock;
    $self;
}


############################################################################
#
#   Name:    Accept, Deny
#
#   Purpose: Methods for accepting or denying a connection
#
#   Inputs:  $con - connection object
#            $msg - Message being sent to the client
#
#   Returns: TRUE for succcess, FALSE otherwise; you might consult
#            the method $con->error in that case.
#
############################################################################

sub Accept($$) {
    my ($self, $msg) = @_;
    $self->Log('debug', "Accepting client.\n");
    $self->_Store([1, $msg]);
}

sub Deny($$) {
    my ($self, $msg) = @_;
    $self->Log('debug', "Denying client.\n");
    $self->_Store([0, $msg]);
}

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


############################################################################
#
#   Name:    Loop
#
#   Purpose: Process client requests
#
#   Inputs:  $con - connection object
#
#   Returns: TRUE, if a client request was successfully processed,
#            FALSE otherwise in which case $con->error is set
#
############################################################################

sub Loop ($) {
    my($self) = shift;
    my($command, $commandRef);
    my(@result);

    if ($self->{'sock'}->eof()) {
	$self->{'error'} = "Cannot talk to Client: EOF";
	$self->Log('err', $self->error);
	return 0;
    }

    my $msg;
    $msg = $self->_Retrieve();
    if (!defined($msg)) {
	$self->{'error'} = "Error while reading client request: "
	    . $self->{'error'};
	$self->Log('err', $self->error);
	return 0;
    }
    my $ok = 0;
    if (ref($msg) ne 'ARRAY') {
	$self->{'error'} = "Error in request data: Expected array.";
    } elsif (!defined($command = shift @$msg)) {
	$self->{'error'} = "Error in request data: Missing command";
    } elsif (!defined($commandRef = $self->{'funcTable'}->{$command})) {
	$self->{'error'} = "Unknown command ($command)";
    } else {
	my($code);
	$code = $commandRef->{'code'};
	($ok, @result) = eval '&$code($self, $commandRef, @$msg)';
	if ($@ ne '') {
	    $ok = 0;
	    $self->{'error'} = "Function evaluation failed: $@";
	} else {
	    if (!defined($ok)) {
		$ok = 0;
	    }
	    if (!$ok) {
		if (@result) {
		    $self->{'error'} = shift @result;
		} else {
		    $self->{'error'} = "Unknown error";
		}
	    } else {
		$self->{'error'} = '';
	    }
	}
    }

    if ($self->error) {
	$self->Log('err', "Client Request -> error " . $self->error);
	$ok = 0;
	@result = ($self->error);
    } elsif ($self->{'debug'}) {
	$self->Log('debug', "$logClass: Client requested $command -> ok");
    }

    if (scalar(@result) == 1  &&  !defined($result[0])) {
	# If we'd simply use @result now, this would give a warning
	# "Use of uninitialized value"; even worse, the returned
	# result would differ from the expected.
	if (!$self->_Store([$ok, undef])) {
	    my $error = $self->error;
	    $self->Log('err', "Error while replying client: $error");
	    $ok = 0;
	}
    } else {
	if (!$self->_Store([$ok, @result])) {
	    my $error = $self->error;
	    $self->Log('err', "Error while replying client: $error");
	    $ok = 0;
	}
    }

    return $ok;
}


############################################################################
#
#   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:    NewHandle, UseHandle, StoreHandle, CallMethod,
#            DestroyHandle
#
#   Purpose: Support functions for working with objects
#
#   Inputs:  $con - server object
#            $ref - hash reference to the entry in $con's function
#                 table being currently executed; this *must* have
#                 an attribute 'handles' which should be a reference
#                 to a hash array which is part of the server
#                 functions local variables; so you are safe in
#                 a multithreaded environment.
#            other input, depending on the method
#
#   Returns: All functions guarantee that $con->error is empty in
#            case of success and nonempty otherwise. StoreHandle
#            guarantees to return 'undef' for error and a
#            defined() value for success; so does UseHandle, at
#            least as long as you don't feed 'undef' objects
#            into 'StoreHandle'. This is guaranteed by 'NewHandle',
#            which satisfies the same behaviour. The results of
#            CallMethod() are unpredictable.
#
############################################################################

sub UseHandle ($$$) {
    my ($con, $ref, $objectHandle) = @_;
    my ($hRef);
    if (!defined($hRef = $ref->{'handles'})  ||  ref($hRef) ne 'HASH') {
	$con->{'error'} = "Mising 'handles' attribute on server";
	return;
    }
    if (!defined($objectHandle)  ||  !exists($hRef->{$objectHandle})) {
	$con->{'error'} = "Unknown object handle";
	return;
    }
    $con->{'error'} = '';
    $hRef->{$objectHandle};
}

sub DestroyHandle ($$$) {
    my ($con, $ref, $objectHandle) = @_;
    my ($hRef);
    if (!defined($hRef = $ref->{'handles'})  ||  ref($hRef) ne 'HASH') {
	$con->{'error'} = "Mising 'handles' attribute on server";
	return 0;
    }
    if (!exists($hRef->{$objectHandle})) {
	$con->{'error'} = "Unknown object handle";
	return 0;
    }
    delete $hRef->{$objectHandle};
    1;
}

sub CallMethod ($$@) {
    my ($con, $ref, $objectHandle, $method, @arg) = @_;
    my ($objectRef) = UseHandle($con, $ref, $objectHandle);
    my (@result);

    if (!defined($objectRef)) {
	$con->{'error'} = "Illegal object handle";
	return(0, $con->error);
    }
    if ($method eq 'DESTROY') {
	if (!DestroyHandle($con, $ref, $objectHandle)) {
	    return (0, $con->error);
	}
    } else {
	if (!$objectRef->can($method)) {
	    $con->{'error'} = "Unknown method: $method";
	    return (0, $con->error);
	}
	(@result) = eval '$objectRef->' . $method . '(@arg)';
	if ($@) {
	    $con->{'error'} = "Error while executing method: $@";
	    return (0, $con->error);
	}
    }
    $con->{'error'} = '';
    (1, @result);
}

sub StoreHandle ($$$) {
    my ($con, $ref, $objectRef) = @_;
    my ($hRef);
    if (!defined($hRef = $ref->{'handles'})  ||  ref($hRef) ne 'HASH') {
	$con->{'error'} = "Mising 'handles' attribute on server";
	return;
    }
    my ($num) = exists($hRef->{'num'}) ? $hRef->{'num'} : 0;
    $hRef->{'num'}  = ++$num;
    $hRef->{$num} = $objectRef;
    $con->{'error'} = '';
    $num;
}

sub NewHandle ($$$@) {
    my ($con, $ref, $classWanted, @arg) = @_;
    my ($lRef) = $ref->{'classes'};

    #  Check, if access to this class is permitted
    my $class;
    foreach $class (@$lRef) {
	if ($class eq $classWanted) {
	    # It is, create the method
	    my $command = $class . '->new(@arg)';
	    my ($object) = eval $command;
	    if ($@) {
		$con->{'error'} = $@;
		return (0, $@);
	    }
	    if (!defined($object)) {
		$con->{'error'} = ' Failed to create object, unknown error';
		return (0, $con->error);
	    }
	    my $handle = StoreHandle($con, $ref, $object);
	    if ($con->error  ||  !defined($handle)) {
		return(0, $con->error);
	    }
	    return (1, $handle);
	}
    }
    $con->{'error'} = "Not permitted to create objects of class $classWanted";
    (0, $con->{'error'});
}

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

1;
__END__