#!/usr/local/bin/perl -w
# p-Server.pl -- Ein einfacher RPC-Server mit RPC::pServer.

use RPC::pServer;                           # CPAN-pRPC-Modul.

# Wir sind ein Server, also erzeugen wir einen passiven Socket!
use constant RPCPORT => 9987;
$serv = IO::Socket::INET->new(LocalPort => RPCPORT,
                  Proto     => 'tcp',
                  Listen    => 5,
                  Reuse     => 1)
    or die "can't create tcp socket: $@\n";

# Wir warten nun nacheinander auf Verbindungswuensche:
use constant RPCAPP     => "my-app";
use constant RPCVERSION => "0.01";
$SIG{'CHLD'} = sub { wait(); };     # Buffy, die Zombie-Killerin.
$dispatcher = {
    'rtime'  => { code => \&rtime },
    'dumpme' => { code => \&dumpme },
    'empmud' => { code => \&empmud },
    'modify' => { code => \&modify }
};

while (1) {
    # Warten auf einen potentiellen Client.
    $conn = new RPC::pServer(sock       => $serv,
                 funcTable  => $dispatcher);

    # Steht die Verbindung?
    unless (ref($conn)) {
    warn "can't create pRPC server: $conn\n";
    next;
    }

    # Sind wir es auch wirklich?
    $conn->Deny("This is a " . RPCAPP . " server. Go away!")
    unless $conn->{'application'} eq RPCAPP;
    $conn->Deny("Your client must be at least " . RPCVERSION. "!")
    unless $conn->{'version'} >= RPCVERSION;
    $conn->Deny("Access denied")
    unless IsAuthorizedUser($conn->{'user'}, $conn->{'password'});

    # Nun erzeugen wir einen Kindprozess fuer die Verbindung.
    if (fork() == 0) {
    # Kindprozess: Eventloop anstossen.
    $conn->Accept("Welcome on board");
    while (1) {
        $conn->Loop();
        exit 0 if $conn->error();
    }
    }
}

# Dies kann eine beliebig komplizierte Funktion sein, die z.B.
# Userdaten aus einer DBI-Datenbank holt, je nach Mondphase
# Zugang gewaehrt oder nicht und weitere lustige Checks durchfuehrt.
use constant RPCUSER => 'gandalf';
use constant RPCPASS => 'ctulhu';
sub IsAuthorizedUser {
    my ($user, $pass) = @_;
    return 1 if $user eq RPCUSER and $pass = RPCPASS;
    return 0;
}

# Hier sind unsere normalen Funktionen.
# $conn ist das spezielle Verbindungsobjekt,
# $xdata koennte als 'data'-Element in der 'funcTable' stehen.
# Alle anderen Parameter gehoeren zur Funktion selbst.
# Rueckgabeliste: ($rc, @returnlist), wobei
# $rc == 1 falls alles okay war,
# $rc == 0 und $returnlist[0] Fehlermeldung bei Fehler.

sub rtime {
    my ($conn, $xdata) = @_;
    return (1, scalar(localtime(time)));
}

use Data::Dumper;
sub dumpme {
    my ($conn, $xdata, $todump) = @_;
    my $dumpedstring = Dumper( $todump );
    return (1, $dumpedstring);
}

sub empmud {
    my ($conn, $xdata, $dumpedstring, @varnames) = @_;
    eval $dumpedstring;
    return $@ ? (0, "Error: $@") :
                (1, map { eval $_ } @varnames);
}

sub modify {
    my ($conn, $xdata, $ptr, $fieldname, $pos, $newvalue) = @_;

    $ptr->{$fieldname}->[$pos] = $newvalue;
    return (1, $ptr);
}