| Current Path : /var/www/web-klick.de/dsh/50_dev2017/1300__perllib/Server/ |
Linux ift1.ift-informatik.de 5.4.0-216-generic #236-Ubuntu SMP Fri Apr 11 19:53:21 UTC 2025 x86_64 |
| Current File : /var/www/web-klick.de/dsh/50_dev2017/1300__perllib/Server/Server.pm |
package Server::Server;
use strict;
use IO::Socket;
use IO::Select;
use Server::ProtocolPERL;
use Server::ProtocolXML;
use Server::ProtocolSTRUCTURE;
use vars qw($AUTOLOAD);
# This package implements both server-side and client-side
# TCP/IP-connectors to realize remote calls.
#
# An instance of Server.pm can act as server as like as client.
# The transport layer is implemented in separate modules.
# Actually there are three Transport-Layer-Modules:
#
# 1. ProtocolPERL: Server and Client are able to exchange
# copies of deep structured perl objects.
# The objects are serialized via the FreezeThaw-Module.
#
# 2. ProtocolXML: Server and client exchange XML-Strings
# so there is the ability to interact with
# processes not exporting freezed Perl-objects.
#
# 3. ProtocolSTRUCTURE: A proprietary format to serve PHP-Clients.
#
#
#
# COMMON FUNCTIONS:
# -----------------
#
# my $server = Server::Server->new(@params);
#
# The parameter list consist of entries as a series of keywords
# (starting with a "-") and values.
#
# Example: Server::Server->new("-protocol","PERL","-fifo","/tmp/fifo.tmp");
#
#
# DEFINITION OF A SERVER OBJECT TO CONNECT TO:
# --------------------------------------------
#
# The qualification of a Server.pm-object needs to define some parameters:
#
# -host: name of server host IP
# -port: port of server to listen on
# -fifo: fifo-socket in the case of the same machine of client
# and server
# -fork: optional, server forks on each call
# if -fork has the parameter <min>,<max>,<repeat>,
# then minimal <min>, maximal <max> server instances
# are running and each instance is used maximal
# <repeat> times: Exampe: -fork 3,7,100
#
# It is clear that either -host and -port or -fifo has to be given.
#
# The exchange protocol is to be given by the keyword
# -protocol in the new-function. The protocol-parameter can be:
#
# <PROTMODULE>_<ID1>_<ID2>_...
#
# where <PROTMODULE> gves the name of the Protocol Modue Suffix.
# At the moment, there is only one Protocol-Module in use, namely:
# ProtocolPERL.pm. so we have: <PROTMODULE> = PERL.
#
# ID1, ID2, .... are optional sub-parameters for the protocol module
# For ProtocolPERL we have:
#
# FREEZE: objects are freezed by FreezeThaw (default)
# NOFREEZE: objects are not freezed (only makes sense
# in the case of pure strings)
# UUENCODE: freezed objects are uuencoded (default)
# BASE64: freezed objects are base64-coded
# NOENCODE: no encoding of the objects
# XML: objects to exchange are complete XML-Strings
# so that socket reading stops after getting
# a valid XML-formatted string.
#
# For example:
#
# my $server = Server::Server->new("-protocol","PERL",
# "-port","4099","-host","localhost");
#
# my $server = Server::Server->new(
# "-protocol","PERL_NOENCODE_NOFREEZE_XML",
# "-fifo","/tmp/fifo.tmp");
#
# a) object-method-server:
#
# The server can be started by calling:
#
# $server->server_run($obj,<fkt>,<paramlist>);
#
# where $obj is an object in the remote envronment, <fkt> a method
# of $obj, followed by a parameter list <paramlist>
# Typically, this method is an endless loop to perform several
# server functions.
#
# b) object-server
#
# The second ability is to call:
#
# $server->server_run->($obj);
#
# Then the remote calls have to qualify the called methd name
# for itselfs.
#
# c) empty server
#
# The third ability is simply to call:
#
# $server->server_run();
#
# Then the remote calls can define objects in the Remote environment
# by certain calls.
#
#
# DEFINITION OF A CLIENT OBJECT:
# ------------------------------
#
# The definition of a client object works in this way: As like
# as the server call, the client has to be informed on the connection
# parameters like -host, -port or -fifo. Such a client-object starts with:
#
# my $client = Server::Server->new("-port","2354","-host 192.168.1.223");
#
# for example.
#
# Qualification as a client object:
#
# $client->client_connect(<PROTOCOL>);
#
# The <PROTOCOL>-Parameter can be given in the above form, but some
# servers (not from Server.pm) may not understand this parameter,
# so it is optional.
#
# REMOTE CALLS:
# -------------
#
# If we have server and clients from Server.pm, remote calls are easy
# and nearly transparent.
#
# To call an empty server, which has protocol "PERL", simply apply:
#
# $client->ff(<paramlist>).
#
# The parameter list is transferred to the remote environment
# and acts like it were local. For example:
#
# my $obj = $client->ff("Package::Example","new","4711");
#
# creates an object in the remote environment by:
#
# Package::Example->new("4711");
#
# and the server gives back a handle on this object. So it is
# possible to treat this local handle as like as the remote
# object. So:
#
# $client->($obj,"func",<params>);
#
# calls the method "func" on the remote object which locally has the handle
# $obj and returns to the local environment.
#
# To call an "object"-server, all calls of ff(...) are directed
# to the spcified server object. The first parameter is the method
# name which has to be called on the server side, followed by
# its parameters.
#
# To call an "object-function" server, all calls of f(....) will call
# the predefined method of the specified server object. It retunrs
# to the local environment.
#
# To get the fully transparency on remote calls in a PERL Environment
# with an empty server, there is the function oo(....) which acts like
# ff(....) but delivers in the local environment a proper object. This
# objct is a dmmuy for the respective server side object, and calls on
# it like:
#
# $obj->func(<params>)
#
# act on the respective remote object; and so the local dummy and
# the remote object have the same behaviour in the local envronment.
#
# So it is equivalent to call:
#
# my $obj = $client->ff("Package::Example","new","4711");
# $client->ff($obj,"func","param1");
#
# and:
#
# my $obj = $client->oo("Package::Example","new","4711");
# $obj->func("param1");
#
# Only one constraint: Don't use for remote objects the method names
# new, read_pars, server_run, client_connect instead of func
# from the second example.
#--------------------------------------------------------------------
# reserved functions: new, read_pars, server_run, client_connect
$SIG{'CHLD'} = sub { wait; };
sub new {
my $class = shift;
my $self = {};
bless($self,$class);
$self->{'___PP___'} = $self->read_pars(@_);
$self->{'___FUNC_HANDLE___'} = {};
return($self);
}
#*********************************************************************
sub init {
my $self = shift;
my $pars = $self->read_pars(@_);
my $o;
foreach $o (keys %$pars) {
$self->{'___PP___'}->{$o} = $pars->{$o};
}
return($self);
}
#*********************************************************************
sub read_pars {
my $self = shift;
my @pars = @_;
return({}) if (!@pars);
my $o; my $o1; my @ee;
push(@pars,"-end");
my $pp = {};
my $text = " " . join(" ",@pars) . " ";
if ($text =~ /-f\s(\S*)/) {
open(FFILE,"<".$1);
$o = "";
while ($o1 = <FFILE>) {
next if ($o1 =~ /^(\s*)\#/);
$o = $o . $o1;
}
close(FFILE);
$o1 = " ";
$o =~ s/\n/$o1/g;
@ee = split(/\s+/,$o);
@pars = (@ee,@pars);
}
$text = " ";
while (0 == 0) {
last if (!@pars);
$o = pop(@pars);
if (substr($o,0,1) eq "-") {
$text =~ s/\s\s//;
if ($text eq " ") { $text = 1; }
$pp->{substr($o,1)} = $text;
$text = " ";
} else {
$text = $o . " " . $text;
}
}
$main::___PP___ = $pp;
return($pp);
}
#*******************************************************************
sub __pp {
my $self = shift;
my $par = shift;
if ($par) { return($self->{'___PP___'}->{$par}); }
return($self->{'___PP___'});
}
#*******************************************************************
#*******************************************************************
# 1. Serverseitige Funktionen
sub __server_connect {
my $self = shift;
my $ppp; my $o; my $sock;
$self->{'___IO___'} = IO::Select->new();
$self->{'___SOCKETS___'} = {};
$self->{'___FORK___'} = $self->__pp("fork");
foreach $o (split(/,/,$self->__pp("port"))) {
$ppp = {};
if ($o =~ /(.*)\:(.*)/) {
$ppp->{'LocalAddr'} = $1;
$o = $2;
} else {
$ppp->{'MultiHomed'} = 1;
}
$ppp->{'LocalPort'} = $o;
$ppp->{'Proto'} = 'tcp';
$ppp->{'ReuseAddr'} = 1;
$ppp->{'Type'} = SOCK_STREAM;
$ppp->{'Listen'} = SOMAXCONN;
$sock = IO::Socket::INET->new(%$ppp);
$self->{'___IO___'}->add($sock);
$self->{'___SOCKETS___'}->{$sock} = 1;
}
foreach $o (split(/,/,$self->__pp("fifo"))) {
$ppp = {};
$ppp->{'Local'} = $o;
$ppp->{'Type'} = SOCK_STREAM;
$ppp->{'Listen'} = SOMAXCONN;
unlink($o);
$sock = IO::Socket::UNIX->new(%$ppp);
$self->{'___SOCKETS___'}->{$sock} = 1;
$self->{'___IO___'}->add($sock);
}
if ($self->__pp("protocol")) { # Statische Protokollfestlegung
$self->__make_protocol($self->__pp("protocol"));
$self->{'___STATIC_PROTOCOL___'} = 1;
}
}
#**********************************************************************
sub server_run {
my $self = shift;
my $obj = shift;
my $func = shift;
if (!($self->{'___IO___'})) {
$self->__server_connect();
}
my $o; my $o1; my @sockets;
my $min_child; my $max_child;
my $forking = 0;
my $cycles = 0;
my $zz = 0;
my $write_pipe;
$o = $self->{'___FORK___'};
if ($o) {
if ($o =~ /(\d+),(\d+),(\d+)/) {
$min_child = $1;
$max_child = $2;
$cycles = $3;
} else {
$forking = 1;
}
}
if ($cycles) {
my $pipes = IO::Select->new();
my $childs = 0;
my @pp; my $read_pipe;
while (0 == 0) {
$o1 = 1;
if ($childs >= $min_child) {
while (@pp = $pipes->can_read()) {
$o1 = 0;
foreach $o (@pp) {
if (eof($o)) {
$pipes->remove($o);
close $o;
$childs = $childs - 1;
if ($childs < $min_child) {
$o1 = $o1 + 1;
}
} else {
my $o2 = <$o>;
if ($childs < $max_child) {
$o1 = $o1 + 1;
}
}
}
last;
}
}
while ($o1) {
$read_pipe = IO::Handle->new();
$write_pipe = IO::Handle->new();
pipe($read_pipe, $write_pipe);
last if (!(fork()));
close($write_pipe);
$pipes->add($read_pipe);
$childs = $childs + 1;
$o1 = $o1 - 1;
}
next if (!$o1);
close($read_pipe);
$write_pipe->autoflush(1);
last;
}
}
while (0 == 0) {
@sockets = $self->{'___IO___'}->can_read();
foreach $o (@sockets) {
if ($self->{'___SOCKETS___'}->{$o}) {
$o1 = $o->accept();
$o1->autoflush(1);
$self->{'___IO___'}->add($o1);
} else {
$o->autoflush(1);
$self->{'___AKTSOCK___'} = $o;
if ($forking) {
if (!(fork())) {
$self->__server_run1($obj,$func);
exit;
}
} else {
if ($cycles) {
if (!$zz) {
print $write_pipe "$$\n";
}
$self->__server_run1($obj,$func);
if ($zz > $cycles) {
close $write_pipe;
exit;
}
$zz = $zz + 1;
} else {
$self->__server_run1($obj,$func);
}
}
if (!($self->{'___STATIC_PROTOCOL___'})) {
delete($self->{'___PROTOCOL___'});
}
$self->{'___IO___'}->remove($o);
close $o;
}
}
}
}
#************************************************************************
sub __server_run1 {
my $self = shift;
my $obj = shift;
my $func = shift;
my $erg; my $o; my $fkt;
if ($obj) {
while (0 == 0) {
($erg,$o) = $self->__server_receive();
return if (!$o);
if (ref($erg) ne "ARRAY") {
$erg = [$erg];
}
if (!$func) {
$func = shift(@$erg);
}
$erg = $obj->$func(@$erg);
$self->__server_send($erg);
}
}
$self->{'OBJSTORE'} = {};
while (0 == 0) {
($erg,$o) = $self->__server_receive();
last if (!$o);
if (ref($erg) ne "ARRAY") {
$erg = [$erg];
}
if ($erg->[1]) {
foreach $o (@$erg) {
$o = $self->__server_objectify($o);
}
$obj = shift(@$erg);
$fkt = shift(@$erg);
$erg = $obj->$fkt(@$erg);
# if (ref($obj)) {
# eval("\$erg = \$obj->".$fkt."(\@\$erg)"); print $@;
# } else {
# eval("\$erg = ".$obj."->".$fkt."(\@\$erg)"); print $@;
# }
$erg = $self->__server_deobjectify($erg);
} else {
delete ($self->{'OBJSTORE'}->{$erg->[0]});
$erg = 1;
}
$self->__server_send($erg);
}
delete ($self->{'OBJSTORE'});
}
#***********************************************************************
sub __server_objectify { # Serialisiert Server-Objekte serverseitig
my $self = shift;
my $obj = shift;
my $o;
if (ref($obj) eq "ARRAY") {
foreach $o (@$obj) {
$o = $self->__server_objectify($o);
}
}
elsif (ref($obj) eq "HASH") {
foreach $o (keys %$obj) {
$obj->{$o} = $self->__server_objectify($obj->{$o});
}
}
elsif (substr($obj,0,9) eq "___OBJ___") {
$obj = $self->{'OBJSTORE'}->{$obj};
}
return($obj);
}
#*******************************************************************
sub __server_deobjectify { # Deserialisiert Server-Objekte serverseitig
my $self = shift;
my $obj = shift;
my $o;
if (ref($obj) eq "ARRAY") {
foreach $o (@$obj) {
$o = $self->__server_deobjectify($o);
}
}
elsif (ref($obj) eq "HASH") {
foreach $o (keys %$obj) {
$obj->{$o} = $self->__server_deobjectify($obj->{$o});
}
}
elsif (ref($obj)) {
$o = "___OBJ___" . $obj;
if (!($self->{'OBJSTORE'}->{$o})) {
$self->{'OBJSTORE'}->{$o} = $obj;
}
$obj = $o;
}
return($obj);
}
#*****************************************************************
sub __server_send {
my $self = shift;
my $obj = shift;
my $sock = $self->{'___AKTSOCK___'};
$self->{'___PROTOCOL___'}->server_send($obj,$self->{'___AKTSOCK___'});
}
#***********************************************************************
sub __server_receive {
my $self = shift;
my $erg;
my $sock = $self->{'___AKTSOCK___'};
if (!($self->{'___PROTOCOL___'})) {
if (eof($sock)) {
return("___EOF___",0);
} else {
$erg = <$sock>;
}
chomp($erg);
$self->__make_protocol($erg);
}
my $o = 1;
($erg,$o) = $self->{'___PROTOCOL___'}->server_receive($sock);
if (!$o) {
$erg = "___EOF___";
$o = 0;
} else {
$o = 1;
}
return($erg,$o);
}
#***********************************************************************
#***********************************************************************
# 2. Clientseitige Funktionen
sub client_connect {
my $self = shift;
my $connection_id = shift;
my $prot = shift; # Vereinbarung des verwendeten Protokolls,
# optional, da nicht jeder Server damit etwas
# anfangen kann.
my $ppp; my @pars; my $o;
# my $proxy_host = $self->__pp("proxy_host");
# my $proxy_port = $self->__pp("proxy_port");
# my $proxy_fifo = $self->__pp("proxy_fifo");
#
# if ($proxy_port or $proxy_fifo) {
#
# if (fork()) {
# @pars = ();
# foreach $o (keys %{$self->__pp()}) {
# if ($o eq "host") { @pars = (@pars,"-host",$proxy_host); }
# elsif ($o eq "port") { @pars = (@pars,"-port",$proxy_port); }
# elsif ($o eq "fifo") { @pars = (@pars,"-fifo",$proxy_fifo); }
# else { @pars = (@pars,"-".$o,$self->__pp($o)); }
# }
# $proxy = Server::Server->new(@pars); # Proxy-Server
# my $obj = Server::Server->new();
# $proxy->run($obj);
# exit;
# }
#
# my $protocol = $prot;
# if (!$prot) { $protocol = $self->__pp("protocol"); }
# my @pars = ("-host","localhost","port",$proxy,
# "-protocol",$protocol,"-fork","1");
# if ($self->__pp("flat")) { @pars = (@pars,"-flat",1); }
# $self->{'___PROXY___'} = Server::Server->new(@pars);
# $self->{'___PROXY___'}->run();
if ($self->__pp("port".$connection_id)) {
$ppp = {};
$ppp->{'Type'} = SOCK_STREAM;
$ppp->{'PeerPort'} = $self->__pp("port".$connection_id);
$ppp->{'PeerHost'} = $self->__pp("host".$connection_id);
$ppp->{'Proto'} = 'tcp';
$self->{'___AKTSOCK___'} = IO::Socket::INET->new(%$ppp);
my $sock = $self->{'___AKTSOCK___'};
}
if ($self->__pp("fifo".$connection_id)) {
$ppp = {};
$ppp->{'Type'} = SOCK_STREAM;
$ppp->{'Peer'} = $self->__pp("fifo".$connection_id);
$self->{'___AKTSOCK___'} = IO::Socket::UNIX->new(%$ppp);
}
if ($prot) { # Dynamische Protokollvereinbarung
$ppp = $self->{'___AKTSOCK___'}; # Server muss ueber das Protokoll
print $ppp $prot . "\n"; # informiert werden
$self->__make_protocol($prot);
}
elsif ($self->__pp("protocol".$connection_id)) { # Statische Protokollvereinbarung
$self->__make_protocol($self->__pp("protocol".$connection_id));
$self->{'___STATIC_PROTOCOL___'} = 1;
}
if ($self->__pp("flat".$connection_id)) {
$self->{'___FLAT___'} = 1;
}
return($self->{'___AKTSOCK___'});
}
#***********************************************************************
sub client_disconnect {
my $self = shift;
$self->{'___AKTSOCK___'}->shutdown(2);
delete ($self->{'___AKTSOCK___'});
return(1);
}
#***********************************************************************
sub __client_objectify { # Objektifiziert Server-Objekte clientseitig
my $self = shift;
my $obj = shift;
my $o;
if (ref($obj) eq "ARRAY") {
foreach $o (@$obj) {
$o = $self->__client_objectify($o);
}
}
elsif (ref($obj) eq "HASH") {
foreach $o (keys %$obj) {
$obj->{$o} = $self->__client_objectify($obj->{$o});
}
}
elsif (substr($obj,0,9) eq "___OBJ___") {
$o = {};
$o->{'CLIENTOBJ'} = $self;
$o->{'OBJHANDLE'} = $obj;
bless($o,ref($self));
$obj = $o;
}
return($obj);
}
#*******************************************************************
sub __client_deobjectify { # Serialisiert Server-Objekte serverseitig
my $self = shift;
my $obj = shift;
my $o;
if (ref($obj) eq "ARRAY") {
foreach $o (@$obj) {
$o = $self->__client_deobjectify($o);
}
}
elsif (ref($obj) eq "HASH") {
foreach $o (keys %$obj) {
$obj->{$o} = $self->__client_deobjectify($obj->{$o});
}
}
elsif (ref($obj)) {
$obj = $obj->__obj_objhandle();
}
return($obj);
}
#*********************************************************************
sub __client_send {
my $self = shift;
my $obj = shift;
my $o;
if ($self->{'___PROTOCOL___'}) {
while (0 == 0) {
$o = $self->{'___PROTOCOL___'}->client_send(
$self->__client_deobjectify($obj),$self->{'___AKTSOCK___'});
last if ($o);
sleep 1;
print "NO_SOCKET\n";
$self->client_connect();
}
}
}
#***********************************************************************
sub __client_receive {
my $self = shift;
my $objects = shift;
my $socket = shift;
my $protocol = shift;
if (!$socket) { $socket = $self->{'___AKTSOCK___'}; }
if (!$protocol) { $protocol = $self->{'___PROTOCOL___'}; }
my ($erg,$o) = $protocol->client_receive($socket);
if (!$o) {
$erg = "___EOF___";
$o = 0;
} else {
$o = 1;
if ($objects) {
$erg = $self->__client_objectify($erg);
}
}
return($erg,$o);
}
#************************************************************************
sub zz {
my $self = shift;
my $sort = shift;
my $pars = shift;
if (($sort == 1) and $self->{'___FLAT___'}) {
print "hier\n";
$self->__client_send(join("\n",@$pars));
}
elsif ($sort < 3) {
$self->__client_send($pars);
}
else {
$self->__client_send(@$pars);
}
my ($erg,$o) = $self->__client_receive( ($sort == 2) );
if (!$o) {
return(0);
} else {
return($erg);
}
}
#************************************************************************
sub zz1 {
my $self = shift;
my $sort = shift;
my $pars = shift;
if (($sort == 1) and $self->{'___FLAT___'}) {
$self->__client_send(join("\n",@$pars)."\n");
}
elsif ($sort < 3) {
$self->__client_send($pars);
}
else {
$self->__client_send(@$pars);
}
my $rp = IO::Handle->new();
my $wp = IO::Handle->new();
pipe($rp,$wp);
my $rp_nr;
while (0 == 0) {
$rp_nr = sprintf("%05u",1 + int(rand(99998)));
next if ($self->{'___FUNC_HANDLE___'}->{$rp_nr});
$self->{'___FUNC_HANDLE___'}->{$rp_nr} = $rp;
last;
}
if (!(fork())) {
close($rp);
$wp->autoflush(1);
my ($erg,$o) = $self->{'___PROTOCOL___'}->client_receive(
$self->{'___AKTSOCK___'});
my $perlprotocol = $self->__make_protocol("PERL",1);
$perlprotocol->server_send([$erg,$o],$wp);
exit;
}
close($wp);
return($rp_nr);
}
#************************************************************************
sub zz2 {
my $self = shift;
my $sort = shift;
my $rp_nr = shift;
my $perlprotocol = $self->__make_protocol("PERL_FREEZE_UUENCODE",1);
my $socket = $self->{'___FUNC_HANDLE___'}->{$rp_nr};
my ($erg_o,$o) = $self->__client_receive(
($sort == 2),$socket,$perlprotocol);
delete ($self->{'___FUNC_HANDLE___'}->{$rp_nr});
if (!$o or !($erg_o->[1])) {
return(0);
} else {
return($erg_o->[0]);
}
}
#************************************************************************
sub ff { my $self = shift; return($self->zz(1,[@_])); }
sub ff1 { my $self = shift; return($self->zz1(1,[@_])); }
sub ff2 { my $self = shift; my $rp_nr = shift; return($self->zz2(1,$rp_nr)); }
sub oo { my $self = shift; return($self->zz(2,[@_])); }
sub oo1 { my $self = shift; return($self->zz1(2,[@_])); }
sub oo2 { my $self = shift; my $rp_nr = shift; return($self->zz2(2,$rp_nr)); }
sub xx { my $self = shift; return($self->zz(3,[@_])); }
sub xx1 { my $self = shift; return($self->zz1(3,[@_])); }
sub xx2 { my $self = shift; my $rp_nr = shift; return($self->zz2(3,$rp_nr)); }
#************************************************************************
#************************************************************************
# 3. Objekt-Funktionen
sub __obj_objhandle {
my $self = shift;
return($self->{'OBJHANDLE'});
}
#************************************************************************
sub AUTOLOAD {
my $self = shift;
my @pars = @_;
$AUTOLOAD =~ /(.*)\::(.*)/;
if ($self->{'CLIENTOBJ'}) {
return($self->{'CLIENTOBJ'}->oo($self->{'OBJHANDLE'},$2,@pars));
}
return(0);
}
#***********************************************************************
sub DESTROY {
my $self = shift;
if ($self->{'CLIENTOBJ'}) {
return($self->{'CLIENTOBJ'}->oo($self->{'OBJHANDLE'}));
}
return(1);
}
#***********************************************************************
sub __make_protocol {
my $self = shift;
my $prot = shift;
my $ret = shift;
my $par;
if ($prot =~ /^(.*?)\_(.*)$/) {
$par = $2;
$prot = $1;
}
$prot = "Server::Protocol" . $prot;
$prot = $prot->new($par);
return($prot) if ($ret);
$self->{'___PROTOCOL___'} = $prot;
}
1;