#!/usr/local/bin/perl
#
#   pRPC - Perl RPC, package for writing simple, RPC like clients and
#       servers
#
#   lib.pl is the base for the test suite.
#
#
#   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: wiedmann@neckar-alb.de
#           Phone: +49 7123 14881
#
#
#   $Id: lib.pl,v 0.1001 1997/09/14 22:53:31 joe Exp $
#


############################################################################
#
#   Modules we use; both pragmatic and true modules
#
############################################################################

use 5.004;
use strict;

use RPC::pServer;
use RPC::pClient;
use IO::Socket();


############################################################################
#
#   Constant values
#
############################################################################

use vars qw{$TEST_APPLICATION $TEST_VERSION $TEST_USER $TEST_PASSWORD};
$TEST_APPLICATION = "Test Application";
$TEST_VERSION = 1.0;
$TEST_USER = "foo";
$TEST_PASSWORD = "bar";


############################################################################
#
#   Global variables
#
############################################################################

use vars qw{$childPid $childGone $verbose};
$childPid = 0;
$childGone = 0;

my ($tblob, $blob) = ('', '');
{
    my $i;
    for ($i = 0;  $i < 256;  $i++) {
	$tblob .= chr($i);
    }
    for ($i = 0;  $i < 256;  $i++) {
	$blob .= $tblob;
    }
}


############################################################################
#
#   Name:    Server
#
#   Purpose: Performs the server tasks: Wait for a connection and
#            perform clients requests.
#
#   Inputs:  $sock - Socket created for the server.
#            $cipher - cipher object being used for encryption
#            $configFile - path of config file
#
#   Result:  Nothing; dies in case of serious errors
#
############################################################################

sub multiply ($$@) {
    my($con, $ref, @args) = @_;
    my($mul) = shift @args;
    my($m);
    while (defined($m = shift @args)) {
	$mul *= $m;
    }
    (1, $mul);
}

sub ListFunc($) {
    my($dir) = shift;
    my ($file, @result);
    if (opendir(DIR, $dir)) {
	while (defined($file = readdir(DIR))) {
	    push(@result, $file);
	}
	closedir(DIR);
    }
    @result;
}

sub listdir ($$@) {
    my ($con, $ref, @args) = @_;
    my ($dir) = shift @args;
    if (-d $dir) {
	(1, ListFunc($dir));
    } else {
	(0, "No such directory: $dir");
    }
}

sub reverseblob ($$$) {
    my ($con, $ref, $gblob) = @_;

    if ($gblob eq $blob) {
	(1, reverse $blob);
    } else {
	(0, "mismatch");
    }
}

sub quitProgram ($$) {
    my ($con, $ref) = @_;
    my ($runRef) = $ref->{'running'};
    $$runRef = 0;
    (1, "Bye!");
}

sub Server ($@) {
    my($sock, $cipher, $configFile) = @_;
    my($con, $running, %handles);

    my ($funcTable) = {
	'quit'     => { 'code' => \&quitProgram, 'running' => \$running },
        'list'     => { 'code' => \&listdir },
        'multiply' => { 'code' => \&multiply },
	'reverseblob' => { 'code' => \&reverseblob },
	'new'      => { 'code' => \&RPC::pServer::NewHandle,
			'handles' => \%handles,
		        'classes' => ['List'] },
	'call'     => { 'code' => \&RPC::pServer::CallMethod,
			'handles' => \%handles }
    };

    $SIG{'ALRM'} = sub { exit 10; };
    alarm 20;

    $con = RPC::pServer->new('sock' => $sock,
			     'cipher' => $cipher,
			     'funcTable' => $funcTable,
			     'configFile' => $configFile,
			     'debug' => 1);

    if (!ref($con)) {
	exit 0;
    }

    $con->Accept();

    $running = 1;
    while ($running) {
	if ($con->{'sock'}->eof()  ||  $con->{'sock'}->error) {
	    exit 0;
	}
        $con->Loop();
    }
    exit 0;
}


############################################################################
#
#   Name:    Client
#
#   Purpose: Performs the client tasks: Connects to the server, calls
#            remote procedures and disconnects.
#
#   Inputs:  $ip - servers ip number
#            $port - servers port number
#            $cipher - cipher object being used for encryption
#
#   Result:  Nothing; dies in case of serious errors
#
############################################################################

sub childGone () {
    my $pid = wait;
    if ($childPid == $pid) {
	$childGone = 1;
    }
    $SIG{CHLD} = \&childGone;
}

sub Client ($$;$) {
    my($ip, $port, $cipher) = @_;
    my($sock, $con);

    $SIG{CHLD} = \&childGone;

    if ($verbose) {
	print "Connecting to $ip, port $port.\n";
    }
    $sock = IO::Socket::INET->new('Proto' => 'tcp',
				  'PeerAddr' => $ip,
				  'PeerPort' => $port);
    if (!defined($sock)) {
	print STDERR "Cannot connect to server: $!\n";
	exit 10;
    }

    $con = RPC::pClient->new('sock' => $sock,
			     'application' => $TEST_APPLICATION,
			     'version' => $TEST_VERSION,
			     'user' => $TEST_USER,
			     'password' => $TEST_PASSWORD,
			     'debug' => 1,
			     'cipher' => $cipher);

    if (!ref($con)) {
	printf STDERR "Failed to connect, error $con.\n";
	exit 10;
    }
    printf("ok 1 Storable OO : %d\n", $RPC::pClient::haveOoStorable);

    #   Call the 'multiply' function.
    my ($mult) = $con->Call('multiply', 3, 4);
    if ($con->error) {
	print "not ok 2 error ", $con->error, "\n";
    } elsif ($mult != 12) {
	print "not ok 2 result $mult\n";
    } else {
	print "ok 2\n";
    }

    #   Call the 'list' function
    my @list = ListFunc(".");
    my (@res, $elem);
    @res = $con->Call('list', ".");
    if ($con->error) {
	print "not ok 3 error ", $con->error, "\n";
    } else {
	my $ok = (@res == @list);
	foreach $elem (@res) {
	    if ($elem ne shift @list) {
		$ok = 0
		}
	}
	if ($ok) {
	    print "ok 3\n";
	} else {
	    print "not ok 3 result @res\n";
	}
    }

    #   Call an illegal function
    my (@ill) = $con->Call('illegal');
    if ($con->error) {
	if (!@ill) {
	    print "ok 4\n";
	} else {
	    print "not ok 4 result @ill\n";
	}
    } else {
	print "not ok 4 expected error\n";
    }

    #   Create a list object
    @list = (1, 2, "a", 4, 5, "c");
    my ($handle) = $con->Call('new', 'List', @list);
    if ($con->error) {
	print "not ok 5 error ", $con->error, "\n";
    } elsif ($handle !~ /^\d+$/) {
	print "not ok 5 handle $handle\n";
    } else {
	print "ok 5\n";
    }

    #   Access the third item
    my ($item) = $con->Call('call', $handle, 'item', 2);
    if ($con->error) {
	print "not ok 6 error ", $con->error, "\n";
    } elsif ($item ne "a") {
	print "not ok 6 item $item\n";
    } else {
	print "ok 6\n";
    }

    #   Access an invalid item
    ($item) = $con->Call('call', $handle, 'item', 7);
    if ($con->error) {
	print "not ok 7 error ", $con->error, "\n";
    } elsif (defined($item)) {
	printf ("not ok 7 item $item, length %s\n", length($item));
    } else {
	print "ok 7\n";
    }

    #   Get the number of items
    my ($items) = $con->Call('call', $handle, 'items');
    if ($con->error) {
	print "not ok 8 error ", $con->error, "\n";
    } elsif ($items ne 6) {
	print "not ok 8 items $items\n";
    } else {
	print "ok 8\n";
    }

    #   Retreive the complete list
    my(@l) = $con->Call('call', $handle, 'list');
    if ($con->error) {
	print "not ok 9 error ", $con->error, "\n";
    } elsif (@l ne @list) {
	print "not ok 9 items ", scalar(@l), "\n";
    } else {
	my $ok = 1;
	my $i;
	for ($i = 0;  $i < @l;  $i++) {
	    if ($l[$i] ne $list[$i]) {
		$ok = 0;
		print "not ok 9 item $i $l[$i]\n";
		last;
	    }
	}
	if ($ok) {
	    print "ok 9\n";
	}
    }

    #   Access an invalid handle
    ($item) = $con->Call('call', $handle+1, 'item', 7);
    if ($con->error) {
	print "ok 10\n";
    } else {
	print "not ok 10 expected error\n";
    }

    #   Destroy the handle
    $con->Call('call', $handle, 'DESTROY');
    if ($con->error) {
	print "not ok 11 error ", $con->error, "\n";
    } else {
	print "ok 11\n";
    }

    #   Try blobs
    my ($gblob) = $con->Call('reverseblob', $blob);
    if ($con->error) {
	print "not ok 12 error ", $con->error, "\n";
    } elsif ($gblob ne $blob) {
	sub ShowBlob($) {
	    my ($blob) = @_;
	    my $i;
	    for($i = 0;  $i < 8;  $i++) {
		if (defined($blob)  &&  length($blob) > $i) {
		    $b = substr($blob, $i*32);
		} else {
		    $b = "";
		}
		printf("%08lx %s\n", $i*32, unpack("H64", $b));
	    }
	}

	print "not ok 12 mismatch\n";
        #ShowBlob($blob);
        #print " vs.\n";
        #ShowBlob(reverse $gblob);
    } else {
	print "ok 12\n";
    }


    if ($childGone) {
	print "not ok 13 child gone previously\n";
	print "not ok 14\n";
	exit 0;
    }

    #   Call the quit function
    $con->Call('quit');
    if ($con->error) {
	print "not ok 13 error ", $con->error, "\n";
    } else {
	print "ok 13\n";
    }

    sleep 10;
    if ($childGone) {
	print "ok 14\n";
        exit 0;
    } else {
	print "not ok 14 child not gone\n";
    }
}


############################################################################
#
#   Create a simple package for testing the handle functions
#
############################################################################

package List;

sub new ($@) {
    my ($proto, @args) = @_;
    my ($class) = ref($proto) || $proto;
    my ($self) = [@args];
    bless($self, $class);
    $self;
}

sub item ($$) {
    my ($self) = shift;
    my ($i) = shift;
    my ($result);

    if ($i < 0  ||  $i >= @$self) {
	$result = undef;
    } else {
	$result = $$self[$i];
    }
    $result;
}

sub items ($) {
    my ($self) = shift;
    scalar(@$self);
}

sub list ($) {
    my ($self) = shift;
    (@$self);
}

1;