File Coverage

blib/lib/RPC/PlServer.pm

Criterion	Covered	Total	%
statement	6	132	4.5
branch	0	70	0.0
condition	0	20	0.0
subroutine	2	15	13.3
pod	0	13	0.0
total	8	250	3.2

#   -*- perl -*-
#
#
#   PlRPC - Perl RPC, package for writing simple, RPC like clients and
#       servers
#
#
#   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;

require Net::Daemon;
require RPC::PlServer::Comm;


package RPC::PlServer;

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


############################################################################
#
#   Name:    Version (Class method)
#
#   Purpose: Returns version string
#
#   Inputs:  $class - This class
#
#   Result:  Version string; suitable for printed by "--version"
#
############################################################################

sub Version ($) {
    "RPC::PlServer application, Copyright (C) 1997, 1998, Jochen Wiedmann";
}


############################################################################
#
#   Name:    Options (Class method)
#
#   Purpose: Returns a hash ref of command line options
#
#   Inputs:  $class - This class
#
#   Result:  Options array; any option is represented by a hash ref;
#            used keys are 'template', a string suitable for describing
#            the option to Getopt::Long::GetOptions and 'description',
#            a string for the Usage message
#
############################################################################

sub Options ($) {
    my $options = shift->SUPER::Options();
    $options->{'maxmessage'} =
	{ 'template' => 'maxmessage=i',
	  'description' =>  '--maxmessage            '
	  . 'Set max message size to  (Default 65535).'
	};
    $options->{'compression'} =
	{ 'template' => 'compression=s',
	  'description' =>  '--compression            '
	  . 'Set compression type to off (default) or gzip.'
	};
    $options;
}


############################################################################
#
#   Name:    AcceptApplication, AcceptVersion, AcceptUser
#            (Instance methods)
#
#   Purpose: Called for authentication purposes; these three in common
#            are replacing Net::Daemon's Accept().
#
#   Inputs:  $self - Server instance
#            $app - Application name
#            $version - Version number
#            $user, $password - User name and password
#
#   Result:  TRUE, if the client has successfully authorized, FALSE
#            otherwise. The AcceptUser method (being called as the
#            last) may additionally return an array ref as a TRUE
#            value: This is treated as welcome message.
#
############################################################################

sub AcceptApplication ($$) {
    my $self = shift; my $app = shift;
    $self->Debug("Client requests application $app");
    UNIVERSAL::isa($self, $app);
}

sub AcceptVersion ($$) {
    my $self = shift; my $version = shift;
    $self->Debug("Client requests version $version");
    no strict 'refs';
    my $myversion = ${ref($self) . "::VERSION"};
    ($version <= $myversion) ? 1 : 0;
}

sub AcceptUser ($$$) {
    my $self = shift; my $user = shift; my $password = shift;

    my $client = $self->{'client'};
    return 1 unless $client->{'users'};
    my $users = $client->{'users'};
    foreach my $u (@$users) {
	my $au;
	if (ref($u)) {
	    $au = $u;
	    $u = defined($u->{'name'}) ? $u->{'name'} : '';
	}
	if ($u eq $user) {
	    $self->{'authorized_user'} = $au;
	    return 1;
	}
    }
    0;
}

sub Accept ($) {
    my $self = shift;
    my $socket = $self->{'socket'};
    my $comm = $self->{'comm'};
    return 0 if (!$self->SUPER::Accept());
    my $client;
    if ($client = $self->{'client'}) {
	if (my $cipher = $client->{'cipher'}) {
	    $self->Debug("Host encryption: %s", $cipher);
	    $self->{'cipher'} = $cipher;
	}
    }

    my $msg = $comm->Read($socket);
    die "Unexpected EOF from client" unless defined $msg;
    die "Login message: Expected array, got $msg" unless ref($msg) eq 'ARRAY';

    my $app      = $self->{'application'} = $msg->[0] || '';
    my $version  = $self->{'version'}     = $msg->[1] || 0;
    my $user     = $self->{'user'}        = $msg->[2] || '';
    my $password = $self->{'password'}    = $msg->[3] || '';

    $self->Debug("Client logs in: Application %s, version %s, user %s",
		 $app, $version, $user);

    if (!$self->AcceptApplication($app)) {
	$comm->Write($socket,
		     [0, "This is a " . ref($self) . " server, go away!"]);
	return 0;
    }
    if (!$self->AcceptVersion($version)) {
	$comm->Write($socket,
		     [0, "Sorry, but I am not running version $version."]);
	return 0;
    }
    my $result;
    if (!($result = $self->AcceptUser($user, $password))) {
	$comm->Write($socket,
		     [0, "User $user is not permitted to connect."]);
	return 0;
    }
    $comm->Write($socket, (ref($result) ? $result : [1, "Welcome!"]));
    if (my $au = $self->{'authorized_user'}) {
	if (ref($au)  &&  (my $cipher = $au->{'cipher'})) {
	    $self->Debug("User encryption: %s", $cipher);
	    $self->{'cipher'} = $cipher;
	}
    }

    if (my $client = $self->{'client'}) {
	if (my $methods = $client->{'methods'}) {
	    $self->{'methods'} = $methods;
	}
    }
    if (my $au = $self->{'authorized_user'}) {
	if (my $methods = $au->{'methods'}) {
	    $self->{'methods'} = $methods;
	}
    }

    1;
}


############################################################################
#
#   Name:    new (Class method)
#
#   Purpose: Constructor
#
#   Inputs:  $class - This class
#            $attr - Hash ref of attributes
#            $args - Array ref of command line arguments
#
#   Result:  Server object for success, error message otherwise
#
############################################################################

sub new ($$;$) {
    my $self = shift->SUPER::new(@_);
    $self->{'comm'} = RPC::PlServer::Comm->new($self);
    $self;
}


############################################################################
#
#   Name:    Run
#
#   Purpose: Process client requests
#
#   Inputs:  $self - Server instance
#
#   Returns: Nothing, dies in case of errors.
#
############################################################################

sub Run ($) {
    my $self = shift;
    my $comm = $self->{'comm'};
    my $socket = $self->{'socket'};

    while (!$self->Done()) {
	my $msg = $comm->Read($socket);
	last unless defined($msg);
	die "Expected array" unless ref($msg) eq 'ARRAY';
	my($error, $command);
	if (!($command = shift @$msg)) {
	    $error = "Expected method name";
	} else {
	    if ($self->{'methods'}) {
		my $class = $self->{'methods'}->{ref($self)};
		if (!$class  ||  !$class->{$command}) {
		    $error = "Not permitted for method $command of class "
			. ref($self);
		}
	    }
	    if (!$error) {
		$self->Debug("Client executes method $command");
		my @result = eval { $self->$command(@$msg) };
		if ($@) {
		    $error = "Failed to execute method $command: $@";
		} else {
		    $comm->Write($socket, \@result);
		}
	    }
	}
	if ($error) {
	    $comm->Write($socket, \$error);
	}
    }
}


############################################################################
#
#   Name:    StoreHandle, NewHandle, UseHandle, DestroyHandle,
#            CallMethod
#
#   Purpose: Support functions for working with objects
#
#   Inputs:  $self - server instance
#            $object - Server side object
#            $handle - Client side handle
#
############################################################################

sub StoreHandle ($$) {
    my $self = shift; my $object = shift;
    my $handle = "$object";
    $self->{'handles'}->{$handle} = $object;
    $handle;
}

sub NewHandle ($$$@) {
    my($self, $handle, $method, @args) = @_;
    my $object = $self->CallMethod($handle, $method, @args);
    die "Constructor $method didn't return a true value" unless $object;
    $self->StoreHandle($object)
}

sub UseHandle ($$) {
    my $self = shift; my $handle = shift;
    $self->{'handles'}->{$handle}  ||  die "No such object: $handle";
}

sub DestroyHandle ($$) {
    my $self = shift; my $handle = shift;
    (delete $self->{'handles'}->{$handle})  ||  die "No such object: $handle";
    ();
}

sub CallMethod ($$$@) {
    my($self, $handle, $method, @args) = @_;
    my($ref, $object);

    my $call_by_instance;
    {
	my $lock = lock($Net::Daemon::RegExpLock)
	    if $Net::Daemon::RegExpLock && $self->{'mode'} eq 'threads';
	$call_by_instance = ($handle =~ /=\w+\(0x/);
    }
    if ($call_by_instance) {
	# Looks like a call by instance
	$object = $self->UseHandle($handle);
	$ref = ref($object);
    } else {
	# Call by class
	$ref = $object = $handle;
    }

    if ($self->{'methods'}) {
	my $class = $self->{'methods'}->{$ref};
	if (!$class  ||  !$class->{$method}) {
	    die "Not permitted for method $method of class $ref";
	}
    }

    $object->$method(@args);
}


1;


__END__