r2572 - in packages: . libevent-rpc-perl libevent-rpc-perl/branches
libevent-rpc-perl/branches/upstream
libevent-rpc-perl/branches/upstream/current
libevent-rpc-perl/branches/upstream/current/examples
libevent-rpc-perl/branches/upstream/current/examples/ssl
libevent-rpc-perl/branches/upstream/current/lib
libevent-rpc-perl/branches/upstream/current/lib/Event
libevent-rpc-perl/branches/upstream/current/lib/Event/RPC
libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Loop
libevent-rpc-perl/branches/upstream/current/t
libevent-rpc-perl/branches/upstream/current/t/ssl
gregor herrmann
gregoa-guest at costa.debian.org
Sat Apr 15 18:15:24 UTC 2006
Author: gregoa-guest
Date: 2006-04-15 18:15:22 +0000 (Sat, 15 Apr 2006)
New Revision: 2572
Added:
packages/libevent-rpc-perl/
packages/libevent-rpc-perl/branches/
packages/libevent-rpc-perl/branches/upstream/
packages/libevent-rpc-perl/branches/upstream/current/
packages/libevent-rpc-perl/branches/upstream/current/Changes
packages/libevent-rpc-perl/branches/upstream/current/MANIFEST
packages/libevent-rpc-perl/branches/upstream/current/META.yml
packages/libevent-rpc-perl/branches/upstream/current/Makefile.PL
packages/libevent-rpc-perl/branches/upstream/current/README
packages/libevent-rpc-perl/branches/upstream/current/examples/
packages/libevent-rpc-perl/branches/upstream/current/examples/Test_class.pm
packages/libevent-rpc-perl/branches/upstream/current/examples/client.pl
packages/libevent-rpc-perl/branches/upstream/current/examples/server.pl
packages/libevent-rpc-perl/branches/upstream/current/examples/ssl/
packages/libevent-rpc-perl/branches/upstream/current/examples/ssl/server.crt
packages/libevent-rpc-perl/branches/upstream/current/examples/ssl/server.csr
packages/libevent-rpc-perl/branches/upstream/current/examples/ssl/server.key
packages/libevent-rpc-perl/branches/upstream/current/lib/
packages/libevent-rpc-perl/branches/upstream/current/lib/Event/
packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC.pm
packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/
packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/AuthPasswdHash.pm
packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Client.pm
packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Connection.pm
packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/LogConnection.pm
packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Logger.pm
packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Loop.pm
packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Loop/
packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Loop/Event.pm
packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Loop/Glib.pm
packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Message.pm
packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Server.pm
packages/libevent-rpc-perl/branches/upstream/current/t/
packages/libevent-rpc-perl/branches/upstream/current/t/01.use.t
packages/libevent-rpc-perl/branches/upstream/current/t/02.cnct.t
packages/libevent-rpc-perl/branches/upstream/current/t/03.cnct-auth.t
packages/libevent-rpc-perl/branches/upstream/current/t/04.cnct-auth-ssl.t
packages/libevent-rpc-perl/branches/upstream/current/t/05.func.t
packages/libevent-rpc-perl/branches/upstream/current/t/Event_RPC_Test.pm
packages/libevent-rpc-perl/branches/upstream/current/t/Event_RPC_Test_Server.pm
packages/libevent-rpc-perl/branches/upstream/current/t/ssl/
packages/libevent-rpc-perl/branches/upstream/current/t/ssl/server.crt
packages/libevent-rpc-perl/branches/upstream/current/t/ssl/server.csr
packages/libevent-rpc-perl/branches/upstream/current/t/ssl/server.key
packages/libevent-rpc-perl/tags/
Log:
[svn-inject] Installing original source of libevent-rpc-perl
Added: packages/libevent-rpc-perl/branches/upstream/current/Changes
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/Changes 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/Changes 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,137 @@
+$Id: Changes,v 1.13 2006/03/27 19:55:16 joern Exp $
+
+Revision history and release notes for Event::RPC:
+
+0.89 Mon Mar 27, 2006, joern
+ Features:
+ - New class_map attribute for Event::RPC::Client to be
+ able to use classes locally which are imported from the
+ server as well, by giving the server classes a different
+ name on the client.
+ - Turn execptions of unregistered object access into
+ warnings, which makes client / server communication
+ more robust and debugging easier.
+
+ Bugfixes:
+ - Fixed crashing when a method declared as an object
+ returner returned undef, which should be absolutely
+ legal.
+ - Fixed client side exceptions if server connection is
+ unexpectedly interrupted during a remote method call.
+ - Exceptions are now stringified before send to the
+ client, otherwise Storable may complain on exception
+ objects which can't be freezed e.g. due to embedded
+ code refs.
+
+0.88 Sat Dec 24, 2005, joern
+ Bugfixes:
+ - Use Storable::nfreeze() to pack network messages, so
+ Event::RPC works with mixed endian architectures
+ as well. Patch by Rolf Grossmann <rg AT PROGTECH.net>.
+
+0.87 Sun Dec 18, 2005, joern
+ Features:
+ - Delegation of authentication resp. user/password check
+ to an external module via Event::RPC::Server attribute
+ "auth_module". Old passwd hash based model is implemented
+ in Event::RPC::AuthPasswdHash.
+ - Fixed a typo in Event::RPC::Looger manpage. Thanks to
+ Sean <soso AT kol.co.nz> for the report.
+ - Cleaned up examples/: server.pl and client.pl now both
+ accept -h option for binding/connecting to a specific
+ host, not just localhost.
+ - Makefile.PL tuning: add detected optional modules to
+ PREREQ_PM to get their version numbers added to CPAN
+ Testers reports.
+
+ Bugfixes:
+ - ChangeLog entry 0.86 was wrong regarding the SSL stuff.
+
+0.86 Sat Dec 17, 2005, joern
+ Features:
+ - added Event::RPC::Server->get_active_connection
+ - documented Event::RPC::Connection->get_client_oids
+ - added Event::RPC::Connection->get_client_object
+
+ Bugfixes:
+ - Added missing documentation for Event::RPC::Client's
+ error_cb attribute, which was just mentioned in
+ the SYNPOSIS.
+ - Fixed an incompatability with IO::Socket::SSL 0.97,
+ which doesn't return different sysread() states for
+ error and eof anymore which confused Event::RPC.
+
+0.85 Sun Aug 28, 2005, joern
+ Bugfixes:
+ - Make server more bullet proof: handle log connections
+ even if no logger is set, but a log listener was started.
+ - Event::RPC::Server->new didn't recognize the
+ 'connection_hook' parameter.
+ - Try making the testsuite more stable with Win32.
+
+0.84 Mon Jul 25, 2005, joern
+ Bugfixes:
+ - Buffering for big incoming RPC requests (> 64KB) didn't
+ work properly
+
+0.83 Fri Apr 15, 2005, joern
+ Features:
+ - Made more parts of the API public by documenting them.
+ - New server option "connection_hook" for accessing
+ Event::RPC::Connection objects during connecting and
+ disconnecting.
+ - New server option "auto_reload_modules" to control the
+ server's auto reloading facility, which was activated
+ by default up to now.
+ - New server option "host" to bind the listener to a
+ specific address. Default is to bind to all addresses.
+ - Increased connect performance by reducing the number
+ of messages exchanged between client and server.
+ - Client may request a subset of exported server classes.
+ Default is still to import all classes exported by the
+ server.
+ - Client checks Event::RPC version and used protocol version
+ on connect and warns different software versions but dies
+ on incompatible protocol versions. Naturally it's
+ recommended to use the same Event::RPC version on server
+ and client.
+ - Methods for getting client and server (after connecting)
+ software and protocol version numbers.
+
+ Bugfixes:
+ - Missed ReuseAddr on listener sockets.
+ - Made testsuite more robust
+ - Network logging clients could block the server by
+ sending data to it.
+ - Renamed client option 'server' to 'host', which is more
+ adequate. 'server' is still allowed but deprecated and
+ using it triggers a warning.
+
+0.82 Sun Apr 10, 2005, joern
+ Notes:
+ - First public release. API is fairly stable.
+
+ Features:
+ - User/password based authentication added.
+ - Full documentation added.
+ - Test suite added which covers all connection
+ types and the most important features.
+
+0.81 Sun Mar 13, 2005, joern
+ Notes:
+ - Still an internal release, incomplete documentation, no
+ test suite.
+
+ Features:
+ - Support for SSL encryption added using IO::Socket::SSL.
+ - Event loop abstraction. Event::RPC now works with Event
+ and Glib and can be easily extended for other event loop
+ frameworks. Thanks to Rocco Caputo for the suggestion.
+
+0.80 Sun Mar 13, 2005, joern
+ Notes:
+ - A non public release. Only announced on the perl-loop mailing
+ list for the namespace request and to get comments. Module
+ is fully working but API isn't documented yet very well.
+ Security stuff (SSL encryption, some password authentication)
+ is missing also a complete test suite.
Added: packages/libevent-rpc-perl/branches/upstream/current/MANIFEST
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/MANIFEST 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/MANIFEST 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,32 @@
+Changes
+MANIFEST
+Makefile.PL
+META.yml
+README
+lib/Event/RPC.pm
+lib/Event/RPC/AuthPasswdHash.pm
+lib/Event/RPC/Client.pm
+lib/Event/RPC/Logger.pm
+lib/Event/RPC/Loop.pm
+lib/Event/RPC/Loop/Event.pm
+lib/Event/RPC/Loop/Glib.pm
+lib/Event/RPC/Message.pm
+lib/Event/RPC/Server.pm
+lib/Event/RPC/Connection.pm
+lib/Event/RPC/LogConnection.pm
+t/01.use.t
+t/02.cnct.t
+t/03.cnct-auth.t
+t/04.cnct-auth-ssl.t
+t/05.func.t
+t/Event_RPC_Test.pm
+t/Event_RPC_Test_Server.pm
+t/ssl/server.crt
+t/ssl/server.csr
+t/ssl/server.key
+examples/server.pl
+examples/client.pl
+examples/Test_class.pm
+examples/ssl/server.key
+examples/ssl/server.csr
+examples/ssl/server.crt
Added: packages/libevent-rpc-perl/branches/upstream/current/META.yml
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/META.yml 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/META.yml 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,17 @@
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+name: Event-RPC
+version: 0.89
+version_from: lib/Event/RPC.pm
+installdirs: site
+requires:
+ Event: 0
+ Glib: 0
+ IO::Socket::INET: 0
+ IO::Socket::SSL: 0
+ Net::SSLeay: 0
+ Storable: 0
+ Test::More: 0
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.30
Added: packages/libevent-rpc-perl/branches/upstream/current/Makefile.PL
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/Makefile.PL 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/Makefile.PL 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,56 @@
+# $Id: Makefile.PL,v 1.3 2005/12/18 13:47:35 joern Exp $
+
+use strict;
+use ExtUtils::MakeMaker;
+
+my $loop_modules = 0;
+my $has_event = 0;
+my $has_glib = 0;
+
+eval { require Event; $has_event = 1 } && ++$loop_modules;
+eval { require Glib; $has_glib = 1 } && ++$loop_modules;
+
+if ( !$loop_modules ) {
+ print "\n";
+ print "*******************************************************\n";
+ print "WARNING: You need Event or Glib for Event::RPC to work!\n";
+ print "*******************************************************\n";
+ print "\n";
+}
+
+my $has_ssl;
+eval { require IO::Socket::SSL; $has_ssl = 1 } || do {
+ print "\n";
+ print "NOTE: Event::RPC is capable of SSL encrypted connections,\n";
+ print " but your Perl is missing the IO::Socket::SSL module.\n";
+ print " Event::RPC works perfectly without the module, but you\n";
+ print " can't use SSL connections until IO::Socket::SSL is\n";
+ print " installed.\n";
+ print "\n";
+};
+
+#-- Add found modules to PREREQ_PM, so CPAN Testers add
+#-- version numbers of these modules to the reports, which
+#-- are very important in case of failing tests.
+my @add_prereq;
+push @add_prereq, 'Event', 0 if $has_event;
+push @add_prereq, 'Glib', 0 if $has_glib;
+push @add_prereq, 'IO::Socket::SSL', 0 if $has_ssl;
+push @add_prereq, 'Net::SSLeay', 0 if $has_ssl;
+
+WriteMakefile(
+ 'NAME' => 'Event::RPC',
+ 'VERSION_FROM' => 'lib/Event/RPC.pm',
+ 'PREREQ_PM' => {
+ 'Test::More' => 0,
+ 'Storable' => 0,
+ 'IO::Socket::INET' => 0,
+ @add_prereq,
+ },
+ 'dist' => {
+ COMPRESS => "gzip",
+ SUFFIX => "gz",
+ PREOP => q[pod2text lib/Event/RPC.pm > README],
+ POSTOP => q[mkdir -p dist && mv Event-RPC-*tar.gz dist/],
+ },
+);
Added: packages/libevent-rpc-perl/branches/upstream/current/README
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/README 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/README 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,165 @@
+NAME
+ Event::RPC - Event based transparent Client/Server RPC framework
+
+SYNOPSIS
+ #-- Server Code
+ use Event::RPC::Server;
+ use My::TestModule;
+ my $server = Event::RPC::Server->new (
+ port => 5555,
+ classes => { "My::TestModule" => { ... } },
+ );
+ $server->start;
+
+ ----------------------------------------------------------
+
+ #-- Client Code
+ use Event::RPC::Client;
+ my $client = Event::RPC::Client->new (
+ server => "localhost",
+ port => 5555,
+ );
+ $client->connect;
+
+ #-- Call methods of My::TestModule on the server
+ my $obj = My::TestModule->new ( foo => "bar" );
+ my $foo = $obj->get_foo;
+
+ABSTRACT
+ Event::RPC supports you in developing Event based networking
+ client/server applications with transparent object/method access from
+ the client to the server. Network communication is optionally encrypted
+ using IO::Socket::SSL. Several event loop managers are supported due to
+ an extensible API. Currently Event and Glib are implemented.
+
+DESCRIPTION
+ Event::RPC consists of a server and a client library. The server exports
+ a list of classes and methods, which are allowed to be called over the
+ network. More specific it acts as a proxy for objects created on the
+ server side (on demand of the connected clients) which handles client
+ side methods calls with transport of method arguments and return values.
+
+ The object proxy handles refcounting and destruction of objects created
+ by clients properly. Objects as method parameters and return values are
+ handled as well (although with some limitations, see below).
+
+ For the client the whole thing is totally transparent - once connected
+ to the server it doesn't know whether it calls methods on local or
+ remote objects.
+
+ Also the methods on the server newer know whether they are called
+ locally or from a connected client. Your application logic is not
+ affected by Event::RPC at all, at least if it has a rudimentary clean OO
+ design.
+
+ For details on implementing servers and clients please refer to the man
+ pages of Event::RPC::Server and Event::RPC::Client.
+
+REQUIREMENTS
+ Event::RPC needs either one of the following modules on the server
+ (they're not necessary on the client):
+
+ Event
+ Glib
+
+ They're needed for event handling resp. mainloop implementation. If you
+ like to use SSL encryption you need to install
+
+ IO::Socket::SSL
+
+ As well Event::RPC makes heavy use of the
+
+ Storable
+
+ module, which is part of the Perl standard library. It's important that
+ both client and server use exactly the same version of the Storable
+ module! Otherwise Event::RPC client/server communication will fail
+ badly.
+
+INSTALLATION
+ You get the latest installation tarballs and online documentation at
+ this location:
+
+ http://www.exit1.org/Event-RPC/
+
+ If your system meets the requirements mentioned above, installation is
+ just:
+
+ perl Makefile.PL
+ make test
+ make install
+
+EXAMPLES
+ The tarball includes an examples/ directory which contains two programs:
+
+ server.pl
+ client.pl
+
+ Just execute them with --help to get the usage. They do some very simple
+ communication but are good to test your setup, in particular in a mixed
+ environment.
+
+LIMITATIONS
+ Although the classes and objects on the server are accessed
+ transparently by the client there are some limitations should be aware
+ of. With a clean object oriented design these should be no problem in
+ real applications:
+
+ Direct object data manipulation is forbidden
+ All objects reside on the server and they keep there! The client just
+ has specially wrapped proxy objects, which trigger the necessary magic
+ to access the object's methods on the server. Complete objects are never
+ transferred from the server to the client, so something like this does
+ not work:
+
+ $object->{data} = "changed data";
+
+ (assuming $object is a hash ref on the server).
+
+ Only method calls are transferred to the server, so even for "simple"
+ data manipulation a method call is necessary:
+
+ $object->set_data ("changed data");
+
+ As well for reading an object attribute. Accessing a hash key will fail:
+
+ my $data = $object->{data};
+
+ Instead call a method which returns the 'data' member:
+
+ my $data = $object->get_data;
+
+ Methods may exchange objects, but not in a too complex structure
+ Event::RPC handles methods which return objects. The only requirement is
+ that they are declared as a Object returner on the server (refer to
+ Event::RPC::Server for details), but not if the object is hided inside a
+ deep complex data structure.
+
+ An array or hash ref of objects is Ok, but not more. This would require
+ to much expensive runtime data inspection.
+
+ Object receiving parameters are more restrictive, since even hiding them
+ inside one array or hash ref is not allowed. They must be passed as a
+ direkt argument of the method subroutine.
+
+AUTHORS
+ Jörn Reder <joern at zyn dot de>
+
+COPYRIGHT AND LICENSE
+ Copyright 2002-2006 by Jörn Reder.
+
+ This library is free software; you can redistribute it and/or modify it
+ under the terms of the GNU Library General Public License as published
+ by the Free Software Foundation; either version 2.1 of the License, or
+ (at your option) any later version.
+
+ This library is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library
+ General Public License for more details.
+
+ You should have received a copy of the GNU Library General Public
+ License along with this library; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307
+ USA.
+
Added: packages/libevent-rpc-perl/branches/upstream/current/examples/Test_class.pm
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/examples/Test_class.pm 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/examples/Test_class.pm 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,50 @@
+# $Id: Test_class.pm,v 1.2 2005/12/18 13:10:14 joern Exp $
+
+#-----------------------------------------------------------------------
+# Copyright (C) 2002-2005 Jörn Reder <joern AT zyn.de>.
+# All Rights Reserved. See file COPYRIGHT for details.
+#
+# This module is part of Event::RPC, which is free software; you can
+# redistribute it and/or modify it under the same terms as Perl itself.
+#-----------------------------------------------------------------------
+
+package Test_class;
+
+use strict;
+
+sub get_data { shift->{data} }
+sub set_data { shift->{data} = $_[1] }
+
+sub new {
+ my $class = shift;
+ my %par = @_;
+ my ($data) = $par{'data'};
+
+ my $self = bless {
+ data => $data,
+ }, $class;
+
+ return $self;
+}
+
+sub hello {
+ my $self = shift;
+
+ return "Hello again. My data is: '".$self->get_data."'";
+}
+
+sub quit {
+ my $self = shift;
+
+ my $rpc_server = Event::RPC::Server->instance;
+
+ $rpc_server->get_loop->add_timer (
+ after => 3,
+ cb => sub { $rpc_server->stop },
+ );
+
+ return "Server stops in 3 seconds";
+}
+
+1;
+
Added: packages/libevent-rpc-perl/branches/upstream/current/examples/client.pl
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/examples/client.pl 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/examples/client.pl 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,108 @@
+#!/usr/bin/perl -w
+
+# $Id: client.pl,v 1.4 2005/12/18 14:01:13 joern Exp $
+
+#-----------------------------------------------------------------------
+# Copyright (C) 2002-2005 Jörn Reder <joern AT zyn.de>.
+# All Rights Reserved. See file COPYRIGHT for details.
+#
+# This module is part of Event::RPC, which is free software; you can
+# redistribute it and/or modify it under the same terms as Perl itself.
+#-----------------------------------------------------------------------
+
+use strict;
+
+use lib 'lib';
+use lib qw(../lib);
+use Event::RPC::Client;
+use Getopt::Std;
+
+my $USAGE = <<__EOU;
+
+Usage: client.pl [-s] [-a user:pass]
+
+Description:
+ Event::RPC client demonstration program. Execute this from
+ the distribution's base or examples/ directory after starting
+ the correspondent examples/server.pl program.
+
+Options:
+ -s Use SSL encryption
+ -a user:pass Pass this authorization data to the server
+ -h host Server hostname. Default: localhost
+
+__EOU
+
+sub HELP_MESSAGE {
+ my ($fh) = @_;
+ $fh ||= \*STDOUT;
+ print $fh $USAGE;
+ exit;
+}
+
+main: {
+ my %opts;
+ my $opts_ok = getopts('h:l:a:s',\%opts);
+
+ HELP_MESSAGE() unless $opts_ok;
+
+ my $ssl = $opts{s} || 0;
+
+ my %auth_args;
+ if ( $opts{a} ) {
+ my ($user, $pass) = split(":", $opts{a});
+ $pass = Event::RPC->crypt($user,$pass);
+ %auth_args = (
+ auth_user => $user,
+ auth_pass => $pass,
+ );
+ }
+
+ #-- Host parameter
+ my $host = $opts{h} || 'localhost';
+
+ #-- This connects to the server, requests the exported
+ #-- interfaces and establishes correspondent proxy methods
+ #-- in the correspondent packages.
+ my $client;
+ $client = Event::RPC::Client->new (
+ host => $host,
+ port => 5555,
+ ssl => $ssl,
+ %auth_args,
+ error_cb => sub {
+ my ($client, $error) = @_;
+ print "An RPC error occured: $_[0]";
+ print "Disconnect and exit.\n";
+ $client->disconnect if $client;
+ exit
+ },
+ classes => [ "Test_class" ],
+ );
+
+ $client->connect;
+
+ print "\nConnected to localhost:5555\n\n";
+ print "Server version: ".$client->get_server_version,"\n";
+ print "Server protocol: ".$client->get_server_protocol,"\n\n";
+
+ #-- So the call to Event::RPC::Test->new is handled transparently
+ #-- by Event::RPC::Client
+ print "** Create object on server\n";
+ my $object = Test_class->new (
+ data => "Initial data",
+ );
+ print "=> Object created with data: '".$object->get_data."'\n\n";
+
+ #-- and methods calls as well...
+ print "** Say hello to server.\n";
+ print "=> Server returned: >>".$object->hello,"<<\n";
+
+ print "\n** Update object data.\n";
+ $object->set_data ("Yes, updating works");
+ print "=> Retrieve data from server: '".$object->get_data."'\n";
+
+ print "\n** Disconnecting\n\n";
+ $client->disconnect;
+
+}
Property changes on: packages/libevent-rpc-perl/branches/upstream/current/examples/client.pl
___________________________________________________________________
Name: svn:executable
+
Added: packages/libevent-rpc-perl/branches/upstream/current/examples/server.pl
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/examples/server.pl 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/examples/server.pl 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,125 @@
+#!/usr/bin/perl -w
+
+# $Id: server.pl,v 1.3 2005/12/18 14:01:13 joern Exp $
+
+#-----------------------------------------------------------------------
+# Copyright (C) 2002-2005 Jörn Reder <joern AT zyn.de>.
+# All Rights Reserved. See file COPYRIGHT for details.
+#
+# This module is part of Event::RPC, which is free software; you can
+# redistribute it and/or modify it under the same terms as Perl itself.
+#-----------------------------------------------------------------------
+
+use strict;
+
+use strict;
+use lib qw( lib ../lib examples .);
+use Event::RPC::Server;
+use Event::RPC::Logger;
+use Getopt::Std;
+
+my $USAGE = <<__EOU;
+
+Usage: server.pl [-l log-level] [-s] [-a user:pass] [-L loop-module]
+
+Description:
+ Event::RPC server demonstration program. Execute this from
+ the distribution's base or examples/ directory. Then execute
+ examples/client.pl on another console.
+
+Options:
+ -l log-level Logging level. Default: 4
+ -s Use SSL encryption
+ -a user:pass Require authorization
+ -h host Bind to this host interface. Default: localhost
+ -L loop-module Event loop module to use.
+ Default: Event::RPC::Loop::Event
+
+__EOU
+
+sub HELP_MESSAGE {
+ my ($fh) = @_;
+ $fh ||= \*STDOUT;
+ print $fh $USAGE;
+ exit;
+}
+
+main: {
+ my %opts;
+ my $opts_ok = getopts('h:L:l:a:s',\%opts);
+
+ HELP_MESSAGE() unless $opts_ok;
+
+ my %ssl_args;
+ if ( $opts{s} ) {
+ %ssl_args = (
+ ssl => 1,
+ ssl_key_file => 'ssl/server.key',
+ ssl_cert_file => 'ssl/server.crt',
+ ssl_passwd_cb => sub { 'eventrpc' },
+ );
+ if ( not -f 'ssl/server.key' ) {
+ chdir ("examples");
+ if ( not -f 'ssl/server.key' ) {
+ print "please execute from toplevel or examples/ directory\n";
+ exit 1;
+ }
+ }
+ }
+
+ my %auth_args;
+ if ( $opts{a} ) {
+ my ($user, $pass) = split(":", $opts{a});
+ $pass = Event::RPC->crypt($user, $pass);
+ %auth_args = (
+ auth_required => 1,
+ auth_passwd_href => { $user => $pass },
+ );
+ }
+
+ #-- Create a logger object
+ my $logger = Event::RPC::Logger->new (
+ min_level => ($opts{l}||4),
+ fh_lref => [ \*STDOUT ],
+ );
+
+ #-- Create a loop object
+ my $loop;
+ my $loop_module = $opts{L};
+ if ( $loop_module ) {
+ eval "use $loop_module";
+ die $@ if $@;
+ $loop = $loop_module->new();
+ }
+
+ #-- Host parameter
+ my $host = $opts{h} || "localhost";
+
+ #-- Create a Server instance and declare the
+ #-- exported interface
+ my $server = Event::RPC::Server->new (
+ name => "test daemon",
+ host => $host,
+ port => 5555,
+ logger => $logger,
+ loop => $loop,
+ start_log_listener => 1,
+ auto_reload_modules => 1,
+ %auth_args,
+ %ssl_args,
+ classes => {
+ 'Test_class' => {
+ new => '_constructor',
+ set_data => 1,
+ get_data => 1,
+ hello => 1,
+ quit => 1,
+ },
+ },
+ );
+
+ #-- Start the server resp. the Event loop.
+ $server->start;
+}
+
+
Property changes on: packages/libevent-rpc-perl/branches/upstream/current/examples/server.pl
___________________________________________________________________
Name: svn:executable
+
Added: packages/libevent-rpc-perl/branches/upstream/current/examples/ssl/server.crt
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/examples/ssl/server.crt 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/examples/ssl/server.crt 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,17 @@
+-----BEGIN CERTIFICATE-----
+MIICozCCAgwCCQC7s/EOvPkeSTANBgkqhkiG9w0BAQQFADCBlTELMAkGA1UEBhMC
+REUxETAPBgNVBAgTCElyZ2VuZHdvMQ4wDAYDVQQHEwVLb2VsbjESMBAGA1UEChMJ
+ZXhpdDEub3JnMR0wGwYDVQQLExRTb2Z0d2FyZSBEZXZlbG9wbWVudDETMBEGA1UE
+AxQKSvZybiBSZWRlcjEbMBkGCSqGSIb3DQEJARYMam9lcm5AenluLmRlMB4XDTA1
+MDMxMzE3NDg1NloXDTE1MDEyMDE3NDg1NlowgZUxCzAJBgNVBAYTAkRFMREwDwYD
+VQQIEwhJcmdlbmR3bzEOMAwGA1UEBxMFS29lbG4xEjAQBgNVBAoTCWV4aXQxLm9y
+ZzEdMBsGA1UECxMUU29mdHdhcmUgRGV2ZWxvcG1lbnQxEzARBgNVBAMUCkr2cm4g
+UmVkZXIxGzAZBgkqhkiG9w0BCQEWDGpvZXJuQHp5bi5kZTCBnzANBgkqhkiG9w0B
+AQEFAAOBjQAwgYkCgYEApKvgMocsWLb3SQw1UukxcCORSDYgge1d1LAGIPlRtLRh
+CCNfUufY8Jslmn/4hZI4wpeRQ5M2NLMkP8kaCgmMviyl20I+jCikLqQFTTMmwU35
+uWoMw343kZA4G6eLqjWVy8NHNABTthgigHaVGWld0lRFpYD4DcWIze50Afg8dl8C
+AwEAATANBgkqhkiG9w0BAQQFAAOBgQAaahVlE9jXt0GO+Zk9ZDUmyiLQ31lhRbvr
+/fFqLYB3WS0xGnKKaj3IQFREkke7an4rhUaZLGstAhF3bXcN//t9bgZKQfnRPsM2
+bQHEVWAtwjebv0Rn0uR53gZBxoCHZyGwCL0Tj0Gvynpou4Y8UDGnfc1E/r+HOTCO
+yvVrQL359w==
+-----END CERTIFICATE-----
Added: packages/libevent-rpc-perl/branches/upstream/current/examples/ssl/server.csr
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/examples/ssl/server.csr 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/examples/ssl/server.csr 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,12 @@
+-----BEGIN CERTIFICATE REQUEST-----
+MIIB1jCCAT8CAQAwgZUxCzAJBgNVBAYTAkRFMREwDwYDVQQIEwhJcmdlbmR3bzEO
+MAwGA1UEBxMFS29lbG4xEjAQBgNVBAoTCWV4aXQxLm9yZzEdMBsGA1UECxMUU29m
+dHdhcmUgRGV2ZWxvcG1lbnQxEzARBgNVBAMUCkr2cm4gUmVkZXIxGzAZBgkqhkiG
+9w0BCQEWDGpvZXJuQHp5bi5kZTCBnzANBgkqhkiG9w0BAQEFAAOBjQAwgYkCgYEA
+pKvgMocsWLb3SQw1UukxcCORSDYgge1d1LAGIPlRtLRhCCNfUufY8Jslmn/4hZI4
+wpeRQ5M2NLMkP8kaCgmMviyl20I+jCikLqQFTTMmwU35uWoMw343kZA4G6eLqjWV
+y8NHNABTthgigHaVGWld0lRFpYD4DcWIze50Afg8dl8CAwEAAaAAMA0GCSqGSIb3
+DQEBBAUAA4GBAJmfq2IqvN+m9IIRzNTHBjEaOeYIEFVKcqWIiui/hvw8M7Yi0op2
+ifOjRKSfYTsgNAst1Ilwg6wgblSngg6f9GpGtWAYr1xQpoWS8PDaqjx1sLE40qi2
+aNrCtrSCLxzLh9o0qeUydcrjvIK6sWe6lGRntjNoj2VCqlBm0EFQ7vNF
+-----END CERTIFICATE REQUEST-----
Added: packages/libevent-rpc-perl/branches/upstream/current/examples/ssl/server.key
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/examples/ssl/server.key 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/examples/ssl/server.key 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,18 @@
+-----BEGIN RSA PRIVATE KEY-----
+Proc-Type: 4,ENCRYPTED
+DEK-Info: DES-EDE3-CBC,CEB8A2E7F9C59066
+
+mUDYr4fgc2lba+qobTYxcq/8ZpRS1cdoiCe1QQeSQ2Bywrsgx8H40hqkBsKOYBPa
+ZFC+EEQTfhGOswTD5YsgqfTyWc7w0qlXDlPCVgV28r96gKzpP6oEDoclriWsToDF
+ZOsANyGcdl4D4VyY+oOf9crUFqIC4C/IfUJ++pZCUlGy8k/J0qHl/kCEP1bPg92q
+tKrG/gcDtrqnVHYB22MruAXHSAo4JOO7A6ZmrRGH4XY5SKGZPF/T7kwLLzEXbPq2
+MDrcPg3xWcCvODswrptdmK73PyF5oWkA7NXAofecu51jW1Y9G48p1lQi0mAgP3qP
+LDxCFQUU52G9UAxmfd8pZBSntRIsaIQV+6ffM8TemObgf1VkisCGDUCnEgvj2zDN
+AaieLhR4MKIQuYZSTLfCI5mKZK0vCFP5t19wK6Clt7p9bq1aUu8HkqEZ5yrNmf04
+acKvUkDbVCPL1pkAsyNAEQ4Zs3f3VxkuRrtf7gqzEEFK1TQoH7JmaALqGftgkPYJ
+eEYX8Om/Gr8NxTftSNbnoaFUyeoBOQ1iZY2g4qqE0rZlc7lfXiXAV3ajtgPcreZa
++uU4g8DF7zfQ7F8FK7w2ryLJFdlgk7SzEjv1VzCQTQ2MjBOCs0gJ3SPF6wx6lfyH
+9HqYRu2OwPJlaTzVrdhwKesROuBr1+rJym18uvzObSgkbTrFQuuYcR0dNbs+AuqQ
+dkhOC6bzpOdZNWVnVQ7klbsj8iUSMs4QnSI0+DpSls5VOMJiAXqPCAy4YJ0GAcGv
+EDF12ONiToyGb0Jolo+WOXyDebHR19TxokTcC5Ri7305mtRAP7g1fQ==
+-----END RSA PRIVATE KEY-----
Added: packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/AuthPasswdHash.pm
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/AuthPasswdHash.pm 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/AuthPasswdHash.pm 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,26 @@
+package Event::RPC::AuthPasswdHash;
+
+use strict;
+use Carp;
+
+sub get_passwd_href { shift->{passwd_href} }
+sub set_passwd_href { shift->{passwd_href} = $_[1] }
+
+sub new {
+ my $class = shift;
+ my ($passwd_href) = @_;
+
+ my $self = bless {
+ passwd_href => $passwd_href,
+ };
+
+ return $self;
+}
+
+sub check_credentials {
+ my $self = shift;
+ my ($user, $pass) = @_;
+ return $pass eq $self->get_passwd_href->{$user};
+}
+
+1;
Added: packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Client.pm
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Client.pm 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Client.pm 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,682 @@
+# $Id: Client.pm,v 1.11 2006/03/27 19:52:45 joern Exp $
+
+#-----------------------------------------------------------------------
+# Copyright (C) 2002-2006 Jörn Reder <joern AT zyn.de>.
+# All Rights Reserved. See file COPYRIGHT for details.
+#
+# This module is part of Event::RPC, which is free software; you can
+# redistribute it and/or modify it under the same terms as Perl itself.
+#-----------------------------------------------------------------------
+
+package Event::RPC::Client;
+
+use Event::RPC;
+use Event::RPC::Message;
+
+use Carp;
+use strict;
+use IO::Socket::INET;
+
+sub get_client_version { $Event::RPC::VERSION }
+sub get_client_protocol { $Event::RPC::PROTOCOL }
+
+sub get_host { shift->{host} }
+sub get_port { shift->{port} }
+sub get_sock { shift->{sock} }
+sub get_classes { shift->{classes} }
+sub get_class_map { shift->{class_map} }
+sub get_loaded_classes { shift->{loaded_classes} }
+sub get_error_cb { shift->{error_cb} }
+sub get_ssl { shift->{ssl} }
+sub get_auth_user { shift->{auth_user} }
+sub get_auth_pass { shift->{auth_pass} }
+sub get_connected { shift->{connected} }
+sub get_server { shift->{server} }
+sub get_server_version { shift->{server_version} }
+sub get_server_protocol { shift->{server_protocol} }
+
+sub set_host { shift->{host} = $_[1] }
+sub set_port { shift->{port} = $_[1] }
+sub set_sock { shift->{sock} = $_[1] }
+sub set_classes { shift->{classes} = $_[1] }
+sub set_class_map { shift->{class_map} = $_[1] }
+sub set_loaded_classes { shift->{loaded_classes} = $_[1] }
+sub set_error_cb { shift->{error_cb} = $_[1] }
+sub set_ssl { shift->{ssl} = $_[1] }
+sub set_auth_user { shift->{auth_user} = $_[1] }
+sub set_auth_pass { shift->{auth_pass} = $_[1] }
+sub set_connected { shift->{connected} = $_[1] }
+sub set_server { shift->{server} = $_[1] }
+sub set_server_version { shift->{server_version} = $_[1] }
+sub set_server_protocol { shift->{server_protocol} = $_[1] }
+
+sub new {
+ my $class = shift;
+ my %par = @_;
+ my ($server, $host, $port, $classes, $class_map, $error_cb) =
+ @par{'server','host','port','classes','class_map','error_cb'};
+ my ($ssl, $auth_user, $auth_pass) =
+ @par{'ssl','auth_user','auth_pass'};
+
+ $server ||= '';
+ $host ||= '';
+
+ if ( $server ne '' and $host eq '' ) {
+ warn "Option 'server' is deprecated. Use 'host' instead.";
+ $host = $server;
+ }
+
+ my $self = bless {
+ host => $server,
+ server => $host,
+ port => $port,
+ classes => $classes,
+ class_map => $class_map,
+ ssl => $ssl,
+ auth_user => $auth_user,
+ auth_pass => $auth_pass,
+ error_cb => $error_cb,
+ loaded_classes => {},
+ connected => 0,
+ }, $class;
+
+ return $self;
+}
+
+sub connect {
+ my $self = shift;
+
+ croak "Client is already connected" if $self->get_connected;
+
+ my $ssl = $self->get_ssl;
+ my $server = $self->get_server;
+ my $port = $self->get_port;
+
+ if ($ssl) {
+ eval { require IO::Socket::SSL };
+ croak "SSL requested, but IO::Socket::SSL not installed" if $@;
+ }
+
+ my $sock;
+ if ($ssl) {
+ $sock = IO::Socket::SSL->new(
+ Proto => 'tcp',
+ PeerPort => $port,
+ PeerAddr => $server,
+ Type => SOCK_STREAM
+ )
+ or croak
+ "Can't open SSL connection to $server:$port: $IO::Socket::SSL::ERROR";
+ }
+ else {
+ $sock = IO::Socket::INET->new(
+ Proto => 'tcp',
+ PeerPort => $port,
+ PeerAddr => $server,
+ Type => SOCK_STREAM
+ )
+ or croak "Can't open connection to $server:$port - $!";
+ }
+
+ $sock->autoflush(1);
+
+ $self->set_sock($sock);
+
+ $self->check_version;
+
+ my $auth_user = $self->get_auth_user;
+ my $auth_pass = $self->get_auth_pass;
+
+ if ($auth_user) {
+ my $rc = $self->send_request(
+ { cmd => 'auth',
+ user => $auth_user,
+ pass => $auth_pass,
+ }
+ );
+ if ( not $rc->{ok} ) {
+ $self->disconnect;
+ croak $rc->{msg};
+ }
+ }
+
+ if ( not $self->get_classes ) {
+ $self->load_all_classes;
+ }
+ else {
+ $self->load_classes;
+ }
+
+ $self->set_connected(1);
+
+ 1;
+}
+
+sub log_connect {
+ my $class = shift;
+ my %par = @_;
+ my ( $server, $port ) = @par{ 'server', 'port' };
+
+ my $sock = IO::Socket::INET->new(
+ Proto => 'tcp',
+ PeerPort => $port,
+ PeerAddr => $server,
+ Type => SOCK_STREAM
+ )
+ or croak "Can't open connection to $server:$port - $!";
+
+ return $sock;
+}
+
+sub disconnect {
+ my $self = shift;
+
+ close( $self->get_sock ) if $self->get_sock;
+ $self->set_connected(0);
+
+ 1;
+}
+
+sub DESTROY {
+ shift->disconnect;
+}
+
+sub error {
+ my $self = shift;
+ my ($message) = @_;
+
+ my $error_cb = $self->get_error_cb;
+
+ if ($error_cb) {
+ &$error_cb( $self, $message );
+ }
+ else {
+ die "Unhandled error in client/server communication: $message";
+ }
+
+ 1;
+}
+
+sub check_version {
+ my $self = shift;
+
+ my $rc = $self->send_request( { cmd => 'version', } );
+
+ $self->set_server_version( $rc->{version} );
+ $self->set_server_protocol( $rc->{protocol} );
+
+ if ( $rc->{version} ne $self->get_client_version ) {
+ warn "Event::RPC warning: server version $rc->{version} != "
+ . "client version "
+ . $self->get_client_version;
+ }
+
+ if ( $rc->{protocol} < $self->get_client_protocol ) {
+ die "FATAL: Server protocol version $rc->{protocol} < "
+ . "client protocol version "
+ . $self->get_client_protocol;
+ }
+
+ 1;
+}
+
+sub load_all_classes {
+ my $self = shift;
+
+ my $rc = $self->send_request( { cmd => 'class_info_all', } );
+
+ my $class_info_all = $rc->{class_info_all};
+
+ foreach my $class ( keys %{$class_info_all} ) {
+ $self->load_class( $class, $class_info_all->{$class} );
+ }
+
+ 1;
+}
+
+sub load_classes {
+ my $self = shift;
+
+ my $classes = $self->get_classes;
+ my %classes;
+ @classes{ @{$classes} } = (1) x @{$classes};
+
+ my $rc = $self->send_request( { cmd => 'classes_list', } );
+
+ foreach my $class ( @{ $rc->{classes} } ) {
+ next if not $classes{$class};
+ $classes{$class} = 0;
+
+ my $rc = $self->send_request(
+ { cmd => 'class_info',
+ class => $class,
+ }
+ );
+
+ $self->load_class( $class, $rc->{methods} );
+ }
+
+ foreach my $class ( @{$classes} ) {
+ warn "WARNING: Class '$class' not exported by server"
+ if $classes{$class};
+ }
+
+ 1;
+}
+
+sub load_class {
+ my $self = shift;
+ my ( $class, $methods ) = @_;
+
+ my $loaded_classes = $self->get_loaded_classes;
+ return 1 if $loaded_classes->{$class};
+ $loaded_classes->{$class} = 1;
+
+ my $local_method;
+ my $class_map = $self->get_class_map;
+ my $local_class = $class_map->{$class} || $class;
+
+ # create local destructor for this class
+ {
+ no strict 'refs';
+ my $local_method = $local_class . '::' . "DESTROY";
+ *$local_method = sub {
+ return if not $self->get_connected;
+ my $oid_ref = shift;
+ $self->send_request({
+ cmd => "client_destroy",
+ oid => ${$oid_ref},
+ });
+ };
+ }
+
+ # create local methods for this class
+ foreach my $method ( keys %{$methods} ) {
+ $local_method = $local_class . '::' . $method;
+
+ my $method_type = $methods->{$method};
+
+ if ( $method_type eq '_constructor' ) {
+ # this is a constructor for this class
+ my $request_method = $class . '::' . $method;
+ no strict 'refs';
+ *$local_method = sub {
+ shift;
+ my $rc = $self->send_request({
+ cmd => 'new',
+ method => $request_method,
+ params => \@_,
+ });
+ my $oid = $rc->{oid};
+ return bless \$oid, $local_class;
+ };
+ }
+ elsif ( $method_type eq '1' ) {
+ # this is a simple method
+ my $request_method = $method;
+ no strict 'refs';
+ *$local_method = sub {
+ my $oid_ref = shift;
+ my $rc = $self->send_request({
+ cmd => 'exec',
+ oid => ${$oid_ref},
+ method => $request_method,
+ params => \@_,
+ });
+ return unless $rc;
+ $rc = $rc->{rc};
+ return @{$rc} if wantarray;
+ return $rc->[0];
+ };
+ }
+ else {
+ # this is a object returner
+ my $request_method = $method;
+ no strict 'refs';
+ *$local_method = sub {
+ my $oid_ref = shift;
+ my $rc = $self->send_request({
+ cmd => 'exec',
+ oid => ${$oid_ref},
+ method => $request_method,
+ params => \@_,
+ });
+ return unless $rc;
+ $rc = $rc->{rc};
+
+ foreach my $val ( @{$rc} ) {
+ if ( ref $val eq 'ARRAY' ) {
+ foreach my $list_elem ( @{$val} ) {
+ my ($class) = split( "=", "$list_elem", 2 );
+ $self->load_class($class)
+ unless $loaded_classes->{$class};
+ my $list_elem_copy = $list_elem;
+ $list_elem = \$list_elem_copy;
+ bless $list_elem,
+ ( $class_map->{$class} || $class );
+ }
+ }
+ elsif ( ref $val eq 'HASH' ) {
+ foreach my $hash_elem ( values %{$val} ) {
+ my ($class) = split( "=", "$hash_elem", 2 );
+ $self->load_class($class)
+ unless $loaded_classes->{$class};
+ my $hash_elem_copy = $hash_elem;
+ $hash_elem = \$hash_elem_copy;
+ bless $hash_elem,
+ ( $class_map->{$class} || $class );
+ }
+ }
+ elsif ( defined $val ) {
+ my ($class) = split( "=", "$val", 2 );
+ $self->load_class($class)
+ unless $loaded_classes->{$class};
+ my $val_copy = $val;
+ $val = \$val_copy;
+ bless $val, ( $class_map->{$class} || $class );
+ }
+ }
+ return @{$rc} if wantarray;
+ return $rc->[0];
+ };
+ }
+ }
+
+ return $local_class;
+}
+
+sub send_request {
+ my $self = shift;
+ my ($request) = @_;
+
+ my $message = Event::RPC::Message->new( $self->get_sock );
+
+ $message->write_blocked($request);
+
+ my $rc = eval { $message->read_blocked };
+
+ if ($@) {
+ $self->error($@);
+ return;
+ }
+
+ if ( not $rc->{ok} ) {
+ $rc->{msg} .= "\n" if not $rc->{msg} =~ /\n$/;
+ croak ("$rc->{msg} -- called via Event::RPC::Client");
+ }
+
+ return $rc;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Event::RPC::Client - Client API to connect to Event::RPC Servers
+
+=head1 SYNOPSIS
+
+ use Event::RPC::Client;
+
+ my $rpc_client = Event::RPC::Client->new (
+ #-- Required arguments
+ host => "localhost",
+ port => 5555,
+
+ #-- Optional arguments
+ classes => [ "Event::RPC::Test" ],
+ class_map => { "Event::RPC::Test" => "My::Event::RPC::Test" },
+
+ ssl => 1,
+
+ auth_user => "fred",
+ auth_pass => Event::RPC->crypt("fred",$password),
+
+ error_cb => sub {
+ my ($client, $error) = @_;
+ print "An RPC error occured: $error\n";
+ $client->disconnect;
+ exit;
+ },
+ );
+
+ $rpc_client->connect;
+
+ #-- And now use classes and methods the server
+ #-- allows to access via RPC, here My::TestModule
+ #-- from the Event::RPC::Server manpage SYNPOSIS.
+ my $obj = My::TestModule->new( data => "foobar" );
+ print "obj says hello: ".$obj->hello."\n";
+ $obj->set_data("new foobar");
+ print "updated data: ".$obj->get_data."\n";
+
+ $rpc_client->disconnect;
+
+=head1 DESCRIPTION
+
+Use this module to write clients accessing objects and methods
+exported by a Event::RPC driven server.
+
+Just connect to the server over the network, optionally with
+SSL and user authentication, and then simply use the exported classes
+and methods like having them locally in the client.
+
+General information about the architecture of Event::RPC driven
+applications is collected in the Event::RPC manpage.
+
+The following documentation describes the client connection
+options in detail.
+
+=head1 CONFIGURATION OPTIONS
+
+You need to specify at least the server hostname and TCP port
+to connect a Event::RPC server instance. If the server requires
+a SSL connection or user authentication you need to supply
+the corresponding options as well, otherwise connecting will
+fail.
+
+All options described here may be passed to the new() constructor of
+Event::RPC::Client. As well you may set or modify them using set_OPTION style
+mutators, but not after connect() was called!
+All options may be read using get_OPTION style accessors.
+
+=head2 REQUIRED OPTIONS
+
+These are necessary to connect the server:
+
+=over 4
+
+=item B<server>
+
+This is the hostname of the server running Event::RPC::Server.
+Use a IP address or DNS name here.
+
+=item B<port>
+
+This is the TCP port the server is listening to.
+
+=back
+
+=head2 CLASS IMPORT OPTION
+
+=over 4
+
+=item B<classes>
+
+This is reference to a list of classes which should be imported
+into the client. You get a warning if you request a class which
+is not exported by the server.
+
+By default all server classes are imported. Use this feature if
+your server exports a huge list of classes, but your client
+doesn't need all of them. This saves memory in the client and
+connect performance increases.
+
+=item B<class_map>
+
+Optionally you can map the class names from the server to a
+different name on the local client using the B<class_map> hash.
+
+This is necessary if you like to use the same classes locally
+and remotely. Imported classes from the server are by default
+registered under the same name on the client, so this conflicts
+with local classes named identically.
+
+On the client you access the remote classes under the name
+assigned in the class map. For example with this map
+
+ class_map => { "Event::ExecFlow::Job" => "_srv::Event::ExecFlow::Job" }
+
+you need to write this on the client, if you like to create
+an object remotely on the server:
+
+ my $server_job = _srv::Event::ExecFlow::Job->new ( ... );
+
+and this to create an object on the client:
+
+ my $client_job = Event::ExecFlow::Job->new ( ... );
+
+The server knows nothing of the renaming on client side, so you
+still write this on the server to create objects there:
+
+ my $job = Event::ExecFlow::Job->new ( ... );
+
+=back
+
+=head2 SSL OPTION
+
+If the server accepts only SSL connections you need to enable
+ssl here in the client as well:
+
+=over 4
+
+=item B<ssl>
+
+Set this option to 1 to encrypt the network connection using SSL.
+
+=back
+
+=head2 AUTHENTICATION OPTIONS
+
+If the server requires user authentication you need to set
+the following options:
+
+=over 4
+
+=item B<auth_user>
+
+A valid username.
+
+=item B<auth_pass>
+
+The corresponding password, encrypted using Perl's crypt() function,
+using the username as the salt.
+
+Event::RPC has a convenience function for generating such a crypted
+password, although it's currently just a wrapper around Perl's
+builtin crypt() function, but probably this changes someday, so better
+use this method:
+
+ $crypted_pass = Event::RPC->crypt($user, $pass);
+
+=back
+
+If the passed credentials are invalid the Event::RPC::Client->connect()
+method throws a correspondent exception.
+
+=head2 ERROR HANDLING
+
+Any exceptions thrown on the server during execution of a remote
+method will result in a corresponding exception on the client. So
+you can use normal exception handling with eval {} when executing
+remote methods.
+
+But besides this the network connection between your client and
+the server may break at any time. This raises an exception as well,
+but you can override this behaviour with the following attribute:
+
+=over 4
+
+=item B<error_cb>
+
+This subroutine is called if any error occurs in the network
+communication between the client and the server. The actual
+Event::RPC::Client object and an error string are passed
+as arguments.
+
+This is B<no> generic exception handler for exceptions thrown from the
+executed methods on the server! If you like to catch such
+exceptions you need to put an eval {} around your method calls,
+as you would do for local method calls.
+
+If you don't specify an B<error_cb> an exception is thrown instead.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item $rpc_client->B<connect>
+
+This establishes the configured connection to the server. An exception
+is thrown if something goes wrong, e.g. server not available, credentials
+are invalid or something like this.
+
+=item $rpc_client->B<disconnect>
+
+Closes the connection to the server. You may omit explicit disconnecting
+since it's done automatically once the Event::RPC::Client object gets
+destroyed.
+
+=back
+
+=head1 READY ONLY ATTRIBUTES
+
+=over 4
+
+=item $rpc_client->B<get_server_version>
+
+Returns the Event::RPC version number of the server after connecting.
+
+=item $rpc_client->B<get_server_protocol>
+
+Returns the Event::RPC protocol number of the server after connecting.
+
+=item $rpc_client->B<get_client_version>
+
+Returns the Event::RPC version number of the client.
+
+=item $rpc_client->B<get_client_protocol>
+
+Returns the Event::RPC protocol number of the client.
+
+=back
+
+=head1 AUTHORS
+
+ Jörn Reder <joern at zyn dot de>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2002-2006 by Jörn Reder.
+
+This library is free software; you can redistribute it and/or modify
+it under the terms of the GNU Library General Public License as
+published by the Free Software Foundation; either version 2.1 of the
+License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Library General Public License for more details.
+
+You should have received a copy of the GNU Library General Public
+License along with this library; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307
+USA.
+
+=cut
+
Added: packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Connection.pm
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Connection.pm 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Connection.pm 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,640 @@
+package Event::RPC::Connection;
+
+use strict;
+use Carp;
+
+my $CONNECTION_ID;
+
+sub get_cid { shift->{cid} }
+sub get_sock { shift->{sock} }
+sub get_server { shift->{server} }
+
+sub get_classes { shift->{server}->{classes} }
+sub get_loaded_classes { shift->{server}->{loaded_classes} }
+sub get_objects { shift->{server}->{objects} }
+sub get_client_oids { shift->{client_oids} }
+
+sub get_watcher { shift->{watcher} }
+sub get_message { shift->{message} }
+sub get_is_authenticated { shift->{is_authenticated} }
+sub get_auth_user { shift->{auth_user} }
+
+sub set_watcher { shift->{watcher} = $_[1] }
+sub set_message { shift->{message} = $_[1] }
+sub set_is_authenticated { shift->{is_authenticated} = $_[1] }
+sub set_auth_user { shift->{auth_user} = $_[1] }
+
+sub new {
+ my $class = shift;
+ my ($server, $sock) = @_;
+
+ my $cid = ++$CONNECTION_ID;
+
+ my $self = bless {
+ cid => $cid,
+ sock => $sock,
+ server => $server,
+ is_authenticated => (!$server->get_auth_required),
+ auth_user => "",
+ watcher => undef,
+ message => undef,
+ client_oids => {},
+ }, $class;
+
+ if ( $sock ) {
+ $self->log (2,
+ "Got new RPC connection. Connection ID is $cid"
+ );
+ $self->{watcher} = $self->get_server->get_loop->add_io_watcher (
+ fh => $sock,
+ poll => 'r',
+ cb => sub { $self->input; 1 },
+ desc => "rpc client cid=$cid",
+ );
+ }
+
+ my $connection_hook = $server->get_connection_hook;
+ &$connection_hook($self, "connect") if $connection_hook;
+
+ return $self;
+}
+
+sub disconnect {
+ my $self = shift;
+
+ $self->get_server->get_loop->del_io_watcher($self->get_watcher);
+ $self->set_watcher(undef);
+ close $self->get_sock;
+
+ my $server = $self->get_server;
+
+ $server->set_clients_connected ( $self->get_server->get_clients_connected - 1 );
+
+ foreach my $oid ( keys %{$self->get_client_oids} ) {
+ $server->deregister_object($oid);
+ }
+
+ $self->log(2, "Client disconnected");
+
+ my $connection_hook = $server->get_connection_hook;
+ &$connection_hook($self, "disconnect") if $connection_hook;
+
+ 1;
+}
+
+sub get_client_object {
+ my $self = shift;
+ my ($oid) = @_;
+
+ croak "No object registered with oid '$oid'"
+ unless $self->get_client_objects->{$oid};
+
+ return $self->get_client_objects->{$oid};
+}
+
+sub log {
+ my $self = shift;
+
+ my ($level, $msg);
+ if ( @_ == 2 ) {
+ ($level, $msg) = @_;
+ } else {
+ ($msg) = @_;
+ $level = 1;
+ }
+
+ $msg = "cid=".$self->get_cid.": $msg";
+
+ return $self->get_server->log ($level, $msg);
+}
+
+sub input {
+ my $self = shift;
+ my ($e) = @_;
+
+ my $server = $self->get_server;
+ my $message = $self->get_message;
+
+ if ( not $message ) {
+ $message = Event::RPC::Message->new ($self->get_sock);
+ $self->set_message($message);
+ }
+
+ my $request = eval { $message->read } || '';
+ my $error = $@;
+
+ return if $request eq '' && $error eq '';
+
+ $self->set_message(undef);
+
+ return $self->disconnect
+ if $request eq "DISCONNECT\n" or
+ $error =~ /DISCONNECTED/;
+
+ $server->set_active_connection($self);
+
+ my ($cmd, $rc);
+ $cmd = $request->{cmd} if not $error;
+
+ $self->log(4, "RPC command: $cmd");
+
+ if ( $error ) {
+ $self->log ("Unexpected error on incoming RPC call: $@");
+ $rc = {
+ ok => 0,
+ msg => "Unexpected error on incoming RPC call: $@",
+ };
+
+ } elsif ( $cmd eq 'version' ) {
+ $rc = {
+ ok => 1,
+ version => $Event::RPC::VERSION,
+ protocol => $Event::RPC::PROTOCOL,
+ };
+
+ } elsif ( $cmd eq 'auth' ) {
+ $rc = $self->authorize_user ($request);
+
+ } elsif ( $server->get_auth_required && !$self->get_is_authenticated ) {
+ $rc = {
+ ok => 0,
+ msg => "Authorization required",
+ };
+
+ } elsif ( $cmd eq 'new' ) {
+ $rc = $self->create_new_object ($request);
+
+ } elsif ( $cmd eq 'exec' ) {
+ $rc = $self->execute_object_method ($request);
+
+ } elsif ( $cmd eq 'classes_list' ) {
+ $rc = $self->get_classes_list ($request);
+
+ } elsif ( $cmd eq 'class_info' ) {
+ $rc = $self->get_class_info ($request);
+
+ } elsif ( $cmd eq 'class_info_all' ) {
+ $rc = $self->get_class_info_all ($request);
+
+ } elsif ( $cmd eq 'client_destroy' ) {
+ $rc = $self->object_destroyed_on_client ($request);
+
+ } else {
+ $self->log ("Unknown request command '$cmd'");
+ $rc = {
+ ok => 0,
+ msg => "Unknown request command '$cmd'",
+ };
+ }
+
+ $server->set_active_connection(undef);
+
+ $message->write($rc) and return;
+
+ my $watcher;
+ $watcher = $self->get_server->get_loop->add_io_watcher (
+ fh => $self->get_sock,
+ poll => 'w',
+ cb => sub {
+ $self->get_server->get_loop->del_io_watcher($watcher)
+ if $message->write;
+ 1;
+ },
+ );
+
+ 1;
+}
+
+sub authorize_user {
+ my $self = shift;
+ my ($request) = @_;
+
+ my $user = $request->{user};
+ my $pass = $request->{pass};
+
+ my $auth_module = $self->get_server->get_auth_module;
+
+ return {
+ ok => 1,
+ msg => "Not authorization required",
+ } unless $auth_module;
+
+ my $ok = $auth_module->check_credentials ($user, $pass);
+
+ if ( $ok ) {
+ $self->set_auth_user($user);
+ $self->set_is_authenticated(1);
+ $self->log("User '$user' successfully authorized");
+ return {
+ ok => 1,
+ msg => "Credentials Ok",
+ };
+ } else {
+ $self->log("Illegal credentials for user '$user'");
+ return {
+ ok => 0,
+ msg => "Illegal credentials",
+ };
+ }
+}
+
+sub create_new_object {
+ my $self = shift;
+ my ($request) = @_;
+
+ # Let's create a new object
+ my $class_method = $request->{method};
+ my $class = $class_method;
+ $class =~ s/::[^:]+$//;
+ $class_method =~ s/^.*:://;
+
+ # check if access to this class/method is allowed
+ if ( not defined $self->get_classes->{$class}->{$class_method} or
+ $self->get_classes->{$class}->{$class_method} ne '_constructor' ) {
+ $self->log ("Illegal constructor access to $class->$class_method");
+ return {
+ ok => 0,
+ msg => "Illegal constructor access to $class->$class_method"
+ };
+
+ }
+
+ # load the class if not done yet
+ $self->load_class($class);
+
+ # resolve object params
+ $self->resolve_object_params ($request->{params});
+
+ # ok, the class is there, let's execute the method
+ my $object = eval {
+ $class->$class_method (@{$request->{params}})
+ };
+
+ # report error
+ if ( $@ ) {
+ $self->log ("Error: can't create object ".
+ "($class->$class_method): $@");
+ return {
+ ok => 0,
+ msg => $@,
+ };
+ }
+
+ # register object
+ $self->get_server->register_object ($object, $class);
+ $self->get_client_oids->{"$object"} = 1;
+
+ # log and return
+ $self->log (5,
+ "Created new object $class->$class_method with oid '$object'",
+ );
+
+ return {
+ ok => 1,
+ oid => "$object",
+ };
+}
+
+sub load_class {
+ my $self = shift;
+ my ($class) = @_;
+
+ my $mtime;
+ my $load_class_info = $self->get_loaded_classes->{$class};
+
+ if ( not $load_class_info or
+ ( $self->get_server->get_auto_reload_modules &&
+ ( $mtime = (stat($load_class_info->{filename}))[9])
+ > $load_class_info->{mtime} ) ) {
+
+ if ( not $load_class_info->{filename} ) {
+ my $filename;
+ my $rel_filename = $class;
+ $rel_filename =~ s!::!/!g;
+ $rel_filename .= ".pm";
+
+ foreach my $dir ( @INC ) {
+ $filename = "$dir/$rel_filename", last
+ if -f "$dir/$rel_filename";
+ }
+
+ croak "File for class '$class' not found"
+ if not $filename;
+
+ $load_class_info->{filename} = $filename;
+ $load_class_info->{mtime} = 0;
+ }
+
+ $mtime ||= 0;
+
+ $self->log (3, "Class '$class' ($load_class_info->{filename}) changed on disk. Reloading...")
+ if $mtime > $load_class_info->{mtime};
+
+ do $load_class_info->{filename};
+
+ if ( $@ ) {
+ $self->log ("Can't load class '$class': $@");
+ $load_class_info->{mtime} = 0;
+
+ return {
+ ok => 0,
+ msg => "Can't load class $class: $@",
+ };
+
+ } else {
+ $self->log (3, "Class '$class' successfully loaded");
+ $load_class_info->{mtime} = time;
+ }
+ }
+
+ $self->log (5, "filename=".$load_class_info->{filename}.
+ ", mtime=".$load_class_info->{mtime} );
+
+ $self->get_loaded_classes->{$class} ||= $load_class_info;
+
+ 1;
+}
+
+sub execute_object_method {
+ my $self = shift;
+ my ($request) = @_;
+
+ # Method call of an existent object
+ my $oid = $request->{oid};
+ my $object_entry = $self->get_objects->{$oid};
+ my $method = $request->{method};
+
+ if ( not defined $object_entry ) {
+ # object does not exists
+ $self->log ("Illegal access to unknown object with oid=$oid");
+ return {
+ ok => 0,
+ msg => "Illegal access to unknown object with oid=$oid"
+ };
+
+ }
+
+ my $class = $object_entry->{class};
+ if ( not defined $self->get_classes->{$class} or
+ not defined $self->get_classes->{$class}->{$method} ) {
+ # illegal access to this method
+ $self->log ("Illegal access to $class->$method");
+ return {
+ ok => 0,
+ msg => "Illegal access to $class->$method"
+ };
+
+ }
+
+ # (re)load the class if not done yet
+ $self->load_class($class);
+
+ # resolve object params
+ $self->resolve_object_params ($request->{params});
+
+ # ok, try executing the method
+ my @rc = eval {
+ $object_entry->{object}->$method (@{$request->{params}})
+ };
+
+ # report error
+ if ( $@ ) {
+ $self->log ("Error: can't call '$method' of object ".
+ "with oid=$oid: $@");
+ return {
+ ok => 0,
+ msg => "$@",
+ };
+ }
+
+ # log
+ $self->log (4, "Called method '$method' of object ".
+ "with oid=$oid");
+
+ # check if objects are returned by this method
+ # and register them in our internal object table
+ # (if not already done yet)
+ my $key;
+ foreach my $rc ( @rc ) {
+ if ( ref ($rc) and ref ($rc) !~ /ARRAY|HASH|SCALAR/ ) {
+ # returns a single object
+ $self->log (4, "Method returns object: $rc");
+ $key = "$rc";
+ $self->get_client_oids->{$key} = 1;
+ $self->get_server->register_object($rc, ref $rc);
+ $rc = $key;
+
+ } elsif ( ref $rc eq 'ARRAY' ) {
+ # possibly returns a list of objects
+ # make a copy, otherwise the original object references
+ # will be overwritten
+ my @val = @{$rc};
+ $rc = \@val;
+ foreach my $val ( @val ) {
+ if ( ref ($val) and ref ($val) !~ /ARRAY|HASH|SCALAR/ ) {
+ $self->log (4, "Method returns object lref: $val");
+ $key = "$val";
+ $self->get_client_oids->{$key} = 1;
+ $self->get_server->register_object($val, ref $val);
+ $val = $key;
+ }
+ }
+ } elsif ( ref $rc eq 'HASH' ) {
+ # possibly returns a hash of objects
+ # make a copy, otherwise the original object references
+ # will be overwritten
+ my %val = %{$rc};
+ $rc = \%val;
+ foreach my $val ( values %val ) {
+ if ( ref ($val) and ref ($val) !~ /ARRAY|HASH|SCALAR/ ) {
+ $self->log (4, "Method returns object href: $val");
+ $key = "$val";
+ $self->get_client_oids->{$key} = 1;
+ $self->get_server->register_object($val, ref $val);
+ $val = $key;
+ }
+ }
+ }
+ }
+
+ # return rc
+ return {
+ ok => 1,
+ rc => \@rc,
+ };
+}
+
+sub object_destroyed_on_client {
+ my $self = shift;
+ my ($request) = @_;
+
+ $self->log(5, "Object with oid=$request->{oid} destroyed on client");
+
+ delete $self->get_client_oids->{$request->{oid}};
+ $self->get_server->deregister_object($request->{oid});
+
+ return {
+ ok => 1
+ };
+}
+
+sub get_classes_list {
+ my $self = shift;
+ my ($request) = @_;
+
+ my @classes = keys %{$self->get_classes};
+
+ return {
+ ok => 1,
+ classes => \@classes,
+ }
+}
+
+sub get_class_info {
+ my $self = shift;
+ my ($request) = @_;
+
+ my $class = $request->{class};
+
+ if ( not defined $self->get_classes->{$class} ) {
+ $self->log ("Unknown class '$class'");
+ return {
+ ok => 0,
+ msg => "Unknown class '$class'"
+ };
+ }
+
+ $self->log (4, "Class info for '$class' requested");
+
+ return {
+ ok => 1,
+ methods => $self->get_classes->{$class},
+ };
+}
+
+sub get_class_info_all {
+ my $self = shift;
+ my ($request) = @_;
+
+ return {
+ ok => 1,
+ class_info_all => $self->get_classes,
+ }
+}
+
+sub resolve_object_params {
+ my $self = shift;
+ my ($params) = @_;
+
+ my $key;
+ foreach my $par ( @{$params} ) {
+ if ( defined $self->get_classes->{ref($par)} ) {
+ $key = ${$par};
+ $key = "$key";
+ croak "unknown object with key '$key'"
+ if not defined $self->get_objects->{$key};
+ $par = $self->get_objects->{$key}->{object};
+ }
+ }
+
+ 1;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Event::RPC::Connection - Represents a RPC connection
+
+=head1 SYNOPSIS
+
+Note: you never create instances of this class in your own code,
+it's only used internally by Event::RPC::Server. But you may request
+connection objects using the B<connection_hook> of Event::RPC::Server
+and then having some read access on them.
+
+ my $connection = Event::RPC::Server::Connection->new (
+ $rpc_server, $client_socket
+ );
+
+As well you can get the currently active connection from your
+Event::RPC::Server object:
+
+ my $server = Event::RPC::Server->instance;
+ my $connection = $server->get_active_connection;
+
+=head1 DESCRIPTION
+
+Objects of this class represents a connection from an Event::RPC::Client
+to an Event::RPC::Server instance. They live inside the server and
+the whole Client/Server protocol is implemented here.
+
+=head1 READ ONLY ATTRIBUTES
+
+The following attributes may be read using the corresponding
+get_ATTRIBUTE accessors:
+
+=over 4
+
+=item B<cid>
+
+The connection ID of this connection. A number which is unique
+for this server instance.
+
+=item B<server>
+
+The Event::RPC::Server instance this connection belongs to.
+
+=item B<is_authenticated>
+
+This boolean value reflects whether the connection is authenticated
+resp. whether the client passed correct credentials.
+
+=item B<auth_user>
+
+This is the name of the user who was authenticated successfully for
+this connection.
+
+=item B<client_oids>
+
+This is a hash reference of object id's which are in use by the client of
+this connection. Keys are the object ids, value is always 1.
+You can get the corresponding objects by using the
+
+ $connection->get_client_object($oid)
+
+method.
+
+Don't change anything in this hash, in particular don't delete or add
+entries. Event::RPC does all the necessary garbage collection transparently,
+no need to mess with that.
+
+=back
+
+=head1 AUTHORS
+
+ Jörn Reder <joern at zyn dot de>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2002-2006 by Jörn Reder.
+
+This library is free software; you can redistribute it and/or modify
+it under the terms of the GNU Library General Public License as
+published by the Free Software Foundation; either version 2.1 of the
+License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Library General Public License for more details.
+
+You should have received a copy of the GNU Library General Public
+License along with this library; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307
+USA.
+
+=cut
+
Added: packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/LogConnection.pm
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/LogConnection.pm 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/LogConnection.pm 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,112 @@
+package Event::RPC::LogConnection;
+
+use Carp;
+use Socket;
+
+my $LOG_CONNECTION_ID;
+
+sub get_cid { shift->{cid} }
+sub get_sock { shift->{sock} }
+sub get_server { shift->{server} }
+
+sub get_watcher { shift->{watcher} }
+sub set_watcher { shift->{watcher} = $_[1] }
+
+sub new {
+ my $class = shift;
+ my ($server, $sock) = @_;
+
+ my $cid = ++$LOG_CONNECTION_ID;
+
+ my $self = bless {
+ cid => $cid,
+ sock => $sock,
+ server => $server,
+ watcher => undef,
+ }, $class;
+
+ $self->{watcher} = $server->get_loop->add_io_watcher(
+ fh => $sock,
+ poll => 'r',
+ cb => sub { $self->input; 1 },
+ desc => "log reader $cid",
+ );
+
+ $self->get_server->log (2,
+ "Got new logger connection. Connection ID is $cid"
+ );
+
+ return $self;
+}
+
+sub disconnect {
+ my $self = shift;
+
+ my $sock = $self->get_sock;
+ $self->get_server->get_logger->remove_fh($sock)
+ if $self->get_server->get_logger;
+ $self->get_server->get_loop->del_io_watcher($self->get_watcher);
+ $self->set_watcher(undef);
+ close $sock;
+
+ $self->get_server->set_log_clients_connected ( $self->get_server->get_log_clients_connected - 1 );
+ delete $self->get_server->get_logging_clients->{$self->get_cid};
+ $self->get_server->log(2, "Log client disconnected");
+
+ 1;
+}
+
+sub input {
+ my $self = shift;
+
+ my $buffer;
+
+ $self->disconnect
+ if not sysread($self->get_sock, $buffer, 4096);
+
+ 1;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Event::RPC::LogConnection - Represents a logging connection
+
+=head1 SYNOPSIS
+
+ # Internal module. No documented public interface.
+
+=head1 DESCRIPTION
+
+Objects of this class are created by Event::RPC server if a
+client connects to the logging port of the server. It's an
+internal module and has no public interface.
+
+=head1 AUTHORS
+
+ Jörn Reder <joern at zyn dot de>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2002-2006 by Jörn Reder.
+
+This library is free software; you can redistribute it and/or modify
+it under the terms of the GNU Library General Public License as
+published by the Free Software Foundation; either version 2.1 of the
+License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Library General Public License for more details.
+
+You should have received a copy of the GNU Library General Public
+License along with this library; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307
+USA.
+
+=cut
+
Added: packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Logger.pm
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Logger.pm 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Logger.pm 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,220 @@
+# $Id: Logger.pm,v 1.4 2006/02/27 14:33:37 joern Exp $
+
+#-----------------------------------------------------------------------
+# Copyright (C) 2002-2006 Jörn Reder <joern AT zyn.de>.
+# All Rights Reserved. See file COPYRIGHT for details.
+#
+# This module is part of Event::RPC, which is free software; you can
+# redistribute it and/or modify it under the same terms as Perl itself.
+#-----------------------------------------------------------------------
+
+package Event::RPC::Logger;
+
+use strict;
+use FileHandle;
+
+sub get_filename { shift->{filename} }
+sub get_filename_fh { shift->{filename_fh} }
+
+sub get_fh_lref { shift->{fh_lref} }
+sub get_min_level { shift->{min_level} }
+
+sub set_fh_lref { shift->{fh_lref} = $_[1] }
+sub set_min_level { shift->{min_level} = $_[1] }
+
+
+sub new {
+ my $class = shift;
+ my %par = @_;
+ my ($filename, $fh_lref, $min_level) =
+ @par{'filename','fh_lref','min_level'};
+
+ my $filename_fh;
+ if ( $filename ) {
+ $filename_fh = FileHandle->new;
+ open ($filename_fh, ">>$filename")
+ or die "can't write log $filename";
+ $filename_fh->autoflush(1);
+ }
+
+ if ( $fh_lref ) {
+ foreach my $fh ( @{$fh_lref} ) {
+ my $old_fh = select $fh;
+ $| = 1;
+ select $old_fh;
+ }
+ } else {
+ $fh_lref = [];
+ }
+
+ my $self = bless {
+ filename => $filename,
+ filename_fh => $filename_fh,
+ fh_lref => $fh_lref,
+ min_level => $min_level,
+ }, $class;
+
+ return $self;
+}
+
+sub DESTROY {
+ my $self = shift;
+
+ my $filename_fh = $self->get_filename_fh;
+ close $filename_fh if $filename_fh;
+
+ 1;
+}
+
+sub log {
+ my $self = shift;
+ my ($level, $msg);
+ if ( @_ == 2 ) {
+ $level = $_[0];
+ $msg = $_[1];
+ } else {
+ $level = 1;
+ $msg = $_[0];
+ }
+
+ return if $level > $self->get_min_level;
+
+ $msg .= "\n" if $msg !~ /\n$/;
+
+ my $str = localtime(time)." [$level] $msg";
+
+ for my $fh ( @{$self->get_fh_lref} ) {
+ print $fh $str if $fh;
+ }
+
+ my $fh = $self->get_filename_fh;
+ print $fh $str if $fh;
+
+ 1;
+}
+
+sub add_fh {
+ my $self = shift;
+ my ($fh) = @_;
+
+ push @{$self->get_fh_lref}, $fh;
+
+ 1;
+}
+
+sub remove_fh {
+ my $self = shift;
+ my ($fh) = @_;
+
+ my $fh_lref = $self->get_fh_lref;
+
+ my $i;
+ for ( $i=0; $i<@{$fh_lref}; ++$i ) {
+ last if $fh_lref->[$i] eq $fh;
+ }
+
+ return if $i == @{$fh_lref};
+ splice @{$fh_lref}, $i, 1;
+
+ 1;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Event::RPC::Logger - Logging facility for Event::RPC
+
+=head1 SYNOPSIS
+
+ use Event::RPC::Server;
+ use Event::RPC::Logger;
+
+ my $server = Event::RPC::Server->new (
+ ...
+ logger => Event::RPC::Logger->new(
+ filename => "/var/log/myserver.log",
+ fh_lref => [ $fh, $sock ],
+ min_level => 2,
+ ),
+ ...
+ );
+
+ $server->start;
+
+=head1 DESCRIPTION
+
+This modules implements a simple logging facility for the
+Event::RPC framework. Log messages may be written to a
+specific file and/or a bunch of filehandles, which may be
+sockets as well.
+
+=head1 CONFIGURATION OPTIONS
+
+This is a list of options you can pass to the new() constructor:
+
+=over 4
+
+=item B<filename>
+
+All log messages are appended to this file.
+
+=item B<fh_lref>
+
+All log messages are printed into this list of filehandles.
+
+=item B<min_level>
+
+This is the minimum log level. Output of messages with a lower level
+is suppressed. This option may be altered using set_min_level() even
+in a running server.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item $logger->B<log> ( [$level, ] $msg )
+
+The log() method does the actual logging. Called with one argument
+the messages gets the default level of 1. With two argumens the first
+is the level for the message.
+
+=item $logger->B<add_fh> ( $fh )
+
+This adds a filehandle to the internal list of filhandles all log
+messages are written to.
+
+=item $logger->B<remove_fh> ( $fh )
+
+Removes a filehandle.
+
+=back
+
+=head1 AUTHORS
+
+ Jörn Reder <joern at zyn dot de>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2002-2006 by Jörn Reder.
+
+This library is free software; you can redistribute it and/or modify
+it under the terms of the GNU Library General Public License as
+published by the Free Software Foundation; either version 2.1 of the
+License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Library General Public License for more details.
+
+You should have received a copy of the GNU Library General Public
+License along with this library; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307
+USA.
+
+=cut
Added: packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Loop/Event.pm
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Loop/Event.pm 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Loop/Event.pm 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,134 @@
+# $Id: Event.pm,v 1.2 2006/02/27 14:33:37 joern Exp $
+
+#-----------------------------------------------------------------------
+# Copyright (C) 2002-2006 Jörn Reder <joern AT zyn.de>.
+# All Rights Reserved. See file COPYRIGHT for details.
+#
+# This module is part of Event::RPC, which is free software; you can
+# redistribute it and/or modify it under the same terms as Perl itself.
+#-----------------------------------------------------------------------
+
+package Event::RPC::Loop::Event;
+
+use base qw( Event::RPC::Loop );
+
+use strict;
+use Event;
+
+sub add_io_watcher {
+ my $self = shift;
+ my %par = @_;
+ my ($fh, $cb, $desc, $poll) = @par{'fh','cb','desc','poll'};
+
+ return Event->io (
+ fd => $fh,
+ poll => $poll,
+ cb => $cb,
+ desc => $desc,
+ reentrant => 0,
+ );
+}
+
+sub del_io_watcher {
+ my $self = shift;
+ my ($watcher) = @_;
+
+ $watcher->cancel;
+
+ 1;
+}
+
+sub add_timer {
+ my $self = shift;
+ my %par = @_;
+ my ($interval, $after, $cb, $desc) =
+ @par{'interval','after','cb','desc'};
+
+ die "interval and after can't be used together"
+ if $interval && $after;
+
+ return Event->timer (
+ interval => $interval,
+ after => $after,
+ cb => $cb,
+ desc => $desc,
+ );
+}
+
+sub del_timer {
+ my $self = shift;
+ my ($timer) = @_;
+
+ $timer->cancel;
+
+ 1;
+}
+
+sub enter {
+ my $self = shift;
+
+ Event::loop();
+
+ 1;
+}
+
+sub leave {
+ my $self = shift;
+
+ Event::unloop_all("ok");
+
+ 1;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Event::RPC::Loop::Event - Event mainloop for Event::RPC
+
+=head1 SYNOPSIS
+
+ use Event::RPC::Server;
+ use Event::RPC::Loop::Event;
+
+ my $server = Event::RPC::Server->new (
+ ...
+ loop => Event::RPC::Loop::Event->new(),
+ ...
+ );
+
+ $server->start;
+
+=head1 DESCRIPTION
+
+This modules implements a mainloop using the Event module
+for the Event::RPC::Server module. It implements the interface
+of Event::RPC::Loop. Please refer to the manpage of
+Event::RPC::Loop for details.
+
+=head1 AUTHORS
+
+ Jörn Reder <joern at zyn dot de>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2002-2006 by Jörn Reder.
+
+This library is free software; you can redistribute it and/or modify
+it under the terms of the GNU Library General Public License as
+published by the Free Software Foundation; either version 2.1 of the
+License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Library General Public License for more details.
+
+You should have received a copy of the GNU Library General Public
+License along with this library; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307
+USA.
+
+=cut
Added: packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Loop/Glib.pm
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Loop/Glib.pm 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Loop/Glib.pm 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,150 @@
+# $Id: Glib.pm,v 1.2 2006/02/27 14:33:37 joern Exp $
+
+#-----------------------------------------------------------------------
+# Copyright (C) 2002-2006 Jörn Reder <joern AT zyn.de>.
+# All Rights Reserved. See file COPYRIGHT for details.
+#
+# This module is part of Event::RPC, which is free software; you can
+# redistribute it and/or modify it under the same terms as Perl itself.
+#-----------------------------------------------------------------------
+
+package Event::RPC::Loop::Glib;
+
+use base qw( Event::RPC::Loop );
+
+use strict;
+use Glib;
+
+sub get_glib_main_loop { shift->{glib_main_loop} }
+sub set_glib_main_loop { shift->{glib_main_loop} = $_[1] }
+
+sub add_io_watcher {
+ my $self = shift;
+ my %par = @_;
+ my ($fh, $cb, $desc, $poll) = @par{'fh','cb','desc','poll'};
+
+ my $cond = $poll eq 'r' ?
+ ['G_IO_IN', 'G_IO_HUP']:
+ ['G_IO_OUT','G_IO_HUP'];
+
+ return Glib::IO->add_watch ($fh->fileno, $cond, sub { &$cb(); 1 } );
+}
+
+sub del_io_watcher {
+ my $self = shift;
+ my ($watcher) = @_;
+
+ Glib::Source->remove ($watcher);
+
+ 1;
+}
+
+sub add_timer {
+ my $self = shift;
+ my %par = @_;
+ my ($interval, $after, $cb, $desc) =
+ @par{'interval','after','cb','desc'};
+
+ die "interval and after can't be used together"
+ if $interval && $after;
+
+ if ( $interval ) {
+ return Glib::Timeout->add (
+ $interval * 1000,
+ sub { &$cb(); 1 }
+ );
+ } else {
+ return Glib::Timeout->add (
+ $after * 1000,
+ sub { &$cb(); 0 }
+ );
+ }
+
+ 1;
+}
+
+sub del_timer {
+ my $self = shift;
+ my ($timer) = @_;
+
+ Glib::Source->remove($timer);
+
+ 1;
+}
+
+sub enter {
+ my $self = shift;
+
+ Glib->install_exception_handler(sub {
+ print "Event::RPC::Loop::Glib caught an exception: $@\n";
+ 1;
+ });
+
+ my $main_loop = Glib::MainLoop->new;
+ $self->set_glib_main_loop($main_loop);
+
+ $main_loop->run;
+
+ 1;
+}
+
+sub leave {
+ my $self = shift;
+
+ $self->get_glib_main_loop->quit;
+
+ 1;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Event::RPC::Loop::Glib - Glib mainloop for Event::RPC
+
+=head1 SYNOPSIS
+
+ use Event::RPC::Server;
+ use Event::RPC::Loop::Glib;
+
+ my $server = Event::RPC::Server->new (
+ ...
+ loop => Event::RPC::Loop::Glib->new(),
+ ...
+ );
+
+ $server->start;
+
+=head1 DESCRIPTION
+
+This modules implements a mainloop using Glib for the
+Event::RPC::Server module. It implements the interface
+of Event::RPC::Loop. Please refer to the manpage of
+Event::RPC::Loop for details.
+
+=head1 AUTHORS
+
+ Jörn Reder <joern at zyn dot de>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2002-2006 by Jörn Reder.
+
+This library is free software; you can redistribute it and/or modify
+it under the terms of the GNU Library General Public License as
+published by the Free Software Foundation; either version 2.1 of the
+License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Library General Public License for more details.
+
+You should have received a copy of the GNU Library General Public
+License along with this library; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307
+USA.
+
+=cut
Added: packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Loop.pm
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Loop.pm 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Loop.pm 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,176 @@
+# $Id: Loop.pm,v 1.2 2006/02/27 14:33:37 joern Exp $
+
+#-----------------------------------------------------------------------
+# Copyright (C) 2002-2006 Jörn Reder <joern AT zyn.de>.
+# All Rights Reserved. See file COPYRIGHT for details.
+#
+# This module is part of Event::RPC, which is free software; you can
+# redistribute it and/or modify it under the same terms as Perl itself.
+#-----------------------------------------------------------------------
+
+package Event::RPC::Loop;
+
+sub new {
+ my $class = shift;
+ return bless {}, $class;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Event::RPC::Loop - Mainloop Abstraction layer for Event::RPC
+
+=head1 SYNOPSIS
+
+ use Event::RPC::Server;
+ use Event::RPC::Loop::Glib;
+
+ my $server = Event::RPC::Server->new (
+ ...
+ loop => Event::RPC::Loop::Glib->new(),
+ ...
+ );
+
+ $server->start;
+
+=head1 DESCRIPTION
+
+This modules defines the interface of Event::RPC's mainloop
+abstraction layer. It's a virtual class all mainloop modules
+should inherit from.
+
+=head1 INTERFACE
+
+The following methods need to be implemented:
+
+=over 4
+
+=item $loop->B<enter> ()
+
+Enter resp. start a mainloop.
+
+=item $loop->B<leave> ()
+
+Leave the mainloop, which was started with the enter() method.
+
+=item $watcher = $loop->B<add_io_watcher> ( %options )
+
+Add an I/O watcher. Options are passed as a hash of
+key/value pairs. The following options are known:
+
+=over 4
+
+=item B<fh>
+
+The filehandle to be watched.
+
+=item B<cb>
+
+This callback is called, without any parameters, if
+an event occured on the filehandle above.
+
+=item B<desc>
+
+A description of the watcher. Not necessarily implemented
+by all modules, so it may be ignored.
+
+=item B<poll>
+
+Either 'r', if your program reads from the filehandle, or 'w'
+if it writes to it.
+
+=back
+
+A watcher object is returned. What this exactly is depends
+on the implementation, so you can't do anything useful with
+it besides passing it back to del_io_watcher().
+
+=item $loop->B<del_io_watcher> ( $watcher )
+
+Deletes an I/O watcher which was added with $loop->add_io_watcher().
+
+=item $timer = $loop->B<add_timer> ( %options )
+
+This sets a timer, a subroutine called after a specific
+timeout or on a regularly basis with a fixed time interval.
+
+Options are passed as a hash of
+key/value pairs. The following options are known:
+
+=over 4
+
+=item B<interval>
+
+A time interval in seconds, may be fractional.
+
+=item B<after>
+
+Callback is called once after this amount of seconds,
+may be fractional.
+
+=item B<cb>
+
+The callback.
+
+=item B<desc>
+
+A description of the timer. Not necessarily implemented
+by all modules, so it may be ignored.
+
+=back
+
+A timer object is returned. What this exactly is depends
+on the implementation, so you can't do anything useful with
+it besides passing it back to del_io_timer().
+
+=item $loop->B<del_timer> ( $timer )
+
+Deletes a timer which was added with $loop->add_timer().
+
+=back
+
+=head1 DIRECT USAGE IN YOUR SERVER
+
+You may use the methods of Event::RPC::Loop by yourself
+if you like. This way your program keeps independent of
+the actual mainloop module in use, if the simplified
+interface of Event::RPC::Loop is sufficient for you.
+
+In your server program you access the actual mainloop
+object this way:
+
+ my $loop = Event::RPC::Server->instance->get_loop;
+
+Naturally nothing speaks against making your program
+to work only with a specific mainloop implementation,
+if you need its features. In that case you may use
+the corresponding API directly (e.g. of Event or Glib),
+no need to access it through Event::RPC::Loop.
+
+=head1 AUTHORS
+
+ Jörn Reder <joern at zyn dot de>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2002-2006 by Jörn Reder.
+
+This library is free software; you can redistribute it and/or modify
+it under the terms of the GNU Library General Public License as
+published by the Free Software Foundation; either version 2.1 of the
+License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Library General Public License for more details.
+
+You should have received a copy of the GNU Library General Public
+License along with this library; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307
+USA.
+
+=cut
Added: packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Message.pm
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Message.pm 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Message.pm 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,194 @@
+# $Id: Message.pm,v 1.5 2006/02/27 14:33:37 joern Exp $
+
+#-----------------------------------------------------------------------
+# Copyright (C) 2002-2006 Jörn Reder <joern AT zyn.de>.
+# All Rights Reserved. See file COPYRIGHT for details.
+#
+# This module is part of Event::RPC, which is free software; you can
+# redistribute it and/or modify it under the same terms as Perl itself.
+#-----------------------------------------------------------------------
+
+package Event::RPC::Message;
+
+use Carp;
+use strict;
+use Storable;
+
+my $DEBUG = 0;
+
+sub get_sock { shift->{sock} }
+
+sub get_buffer { shift->{buffer} }
+sub get_length { shift->{length} }
+sub get_written { shift->{written} }
+
+sub set_buffer { shift->{buffer} = $_[1] }
+sub set_length { shift->{length} = $_[1] }
+sub set_written { shift->{written} = $_[1] }
+
+sub new {
+ my $class = shift;
+ my ($sock) = @_;
+
+ $sock->blocking(1);
+
+ my $self = bless {
+ sock => $sock,
+ buffer => undef,
+ length => 0,
+ written => 0,
+ }, $class;
+
+ return $self;
+}
+
+sub read {
+ my $self = shift;
+
+ if ( not defined $self->{buffer} ) {
+ my $length_packed;
+ $DEBUG && print "DEBUG: going to read header...\n";
+ my $rc = sysread ($self->get_sock, $length_packed, 4);
+ $DEBUG && print "DEBUG: header read rc=$rc\n";
+ die "DISCONNECTED" if !(defined $rc) || $rc == 0;
+ $self->{length} = unpack("N", $length_packed);
+ $DEBUG && print "DEBUG: packet size=$self->{length}\n";
+ die "Incoming message too big"
+ if $self->{length} > 4194304;
+ }
+
+ my $buffer_length = length($self->{buffer}||'');
+
+ $DEBUG && print "DEBUG: going to read packet... (buffer_length=$buffer_length)\n";
+
+ my $rc = sysread (
+ $self->get_sock,
+ $self->{buffer},
+ $self->{length} - $buffer_length,
+ $buffer_length
+ );
+
+ $DEBUG && print "DEBUG: packet read rc=$rc\n";
+
+ return if not defined $rc;
+ die "DISCONNECTED" if $rc == 0;
+
+ $buffer_length = length($self->{buffer});
+
+ $DEBUG && print "DEBUG: more to read... ($self->{length} != $buffer_length)\n"
+ if $self->{length} != $buffer_length;
+
+ return if $self->{length} != $buffer_length;
+
+ $DEBUG && print "DEBUG: read finished, length=$buffer_length\n";
+
+ my $data = Storable::thaw($self->{buffer});
+
+ $self->{buffer} = undef;
+ $self->{length} = 0;
+
+ return $data;
+}
+
+sub read_blocked {
+ my $self = shift;
+
+ my $rc;
+ $rc = $self->read while not defined $rc;
+
+ return $rc;
+}
+
+sub write {
+ my $self = shift;
+ my ($data) = @_;
+
+ $DEBUG && print "DEBUG: going to write...\n";
+
+ if ( not defined $self->{buffer} ) {
+ my $packed = Storable::nfreeze ($data);
+ $self->{buffer} = pack("N", length($packed)).$packed;
+ $self->{length} = length($self->{buffer});
+ $self->{written} = 0;
+ }
+
+ my $rc = syswrite (
+ $self->get_sock,
+ $self->{buffer},
+ $self->{length}-$self->{written},
+ $self->{written},
+ );
+
+ $DEBUG && print "DEBUG: written rc=$rc\n";
+
+ return if not defined $rc;
+
+ $self->{written} += $rc;
+
+ if ( $self->{written} == $self->{length} ) {
+ $DEBUG && print "DEBUG: write finished\n";
+ $self->{buffer} = undef;
+ $self->{length} = 0;
+ return 1;
+ }
+
+ $DEBUG && print "DEBUG: more to be written...\n";
+
+ return;
+}
+
+sub write_blocked {
+ my $self = shift;
+ my ($data) = @_;
+
+ $self->write($data) and return;
+
+ my $finished = 0;
+ $finished = $self->write while not $finished;
+
+ 1;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Event::RPC::Message - Implementation of Event::RPC network protocol
+
+=head1 SYNOPSIS
+
+ # Internal module. No documented public interface.
+
+=head1 DESCRIPTION
+
+This module implements the network protocol of Event::RPC.
+Objects of this class are created internally by Event::RPC::Server
+and Event::RPC::Client and performs message passing over the
+network.
+
+=head1 AUTHORS
+
+ Jörn Reder <joern at zyn dot de>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2002-2006 by Jörn Reder.
+
+This library is free software; you can redistribute it and/or modify
+it under the terms of the GNU Library General Public License as
+published by the Free Software Foundation; either version 2.1 of the
+License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Library General Public License for more details.
+
+You should have received a copy of the GNU Library General Public
+License along with this library; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307
+USA.
+
+=cut
Added: packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Server.pm
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Server.pm 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC/Server.pm 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,838 @@
+# $Id: Server.pm,v 1.9 2006/02/27 14:33:37 joern Exp $
+
+#-----------------------------------------------------------------------
+# Copyright (C) 2002-2006 Jörn Reder <joern AT zyn.de>.
+# All Rights Reserved. See file COPYRIGHT for details.
+#
+# This module is part of Event::RPC, which is free software; you can
+# redistribute it and/or modify it under the same terms as Perl itself.
+#-----------------------------------------------------------------------
+
+package Event::RPC::Server;
+
+use Event::RPC;
+use Event::RPC::Message;
+use Event::RPC::Connection;
+use Event::RPC::LogConnection;
+
+use Carp;
+use strict;
+use IO::Socket::INET;
+use Sys::Hostname;
+
+sub get_host { shift->{host} }
+sub get_port { shift->{port} }
+sub get_name { shift->{name} }
+sub get_loop { shift->{loop} }
+sub get_classes { shift->{classes} }
+sub get_loaded_classes { shift->{loaded_classes} }
+sub get_clients_connected { shift->{clients_connected} }
+sub get_log_clients_connected { shift->{log_clients_connected} }
+sub get_logging_clients { shift->{logging_clients} }
+sub get_logger { shift->{logger} }
+sub get_start_log_listener { shift->{start_log_listener} }
+sub get_objects { shift->{objects} }
+sub get_rpc_socket { shift->{rpc_socket} }
+sub get_ssl { shift->{ssl} }
+sub get_ssl_key_file { shift->{ssl_key_file} }
+sub get_ssl_cert_file { shift->{ssl_cert_file} }
+sub get_ssl_passwd_cb { shift->{ssl_passwd_cb} }
+sub get_auth_required { shift->{auth_required} }
+sub get_auth_passwd_href { shift->{auth_passwd_href} }
+sub get_auth_module { shift->{auth_module} }
+sub get_listeners_started { shift->{listeners_started} }
+sub get_connection_hook { shift->{connection_hook} }
+sub get_auto_reload_modules { shift->{auto_reload_modules} }
+sub get_active_connection { shift->{active_connection} }
+
+sub set_host { shift->{host} = $_[1] }
+sub set_port { shift->{port} = $_[1] }
+sub set_name { shift->{name} = $_[1] }
+sub set_loop { shift->{loop} = $_[1] }
+sub set_classes { shift->{classes} = $_[1] }
+sub set_loaded_classes { shift->{loaded_classes} = $_[1] }
+sub set_clients_connected { shift->{clients_connected} = $_[1] }
+sub set_log_clients_connected { shift->{log_clients_connected}= $_[1] }
+sub set_logging_clients { shift->{logging_clients} = $_[1] }
+sub set_logger { shift->{logger} = $_[1] }
+sub set_start_log_listener { shift->{start_log_listener} = $_[1] }
+sub set_objects { shift->{objects} = $_[1] }
+sub set_rpc_socket { shift->{rpc_socket} = $_[1] }
+sub set_ssl { shift->{ssl} = $_[1] }
+sub set_ssl_key_file { shift->{ssl_key_file} = $_[1] }
+sub set_ssl_cert_file { shift->{ssl_cert_file} = $_[1] }
+sub set_ssl_passwd_cb { shift->{ssl_passwd_cb} = $_[1] }
+sub set_auth_required { shift->{auth_required} = $_[1] }
+sub set_auth_passwd_href { shift->{auth_passwd_href} = $_[1] }
+sub set_auth_module { shift->{auth_module} = $_[1] }
+sub set_listeners_started { shift->{listeners_started} = $_[1] }
+sub set_connection_hook { shift->{connection_hook} = $_[1] }
+sub set_auto_reload_modules { shift->{auto_reload_modules} = $_[1] }
+sub set_active_connection { shift->{active_connection} = $_[1] }
+
+my $INSTANCE;
+sub instance { $INSTANCE }
+
+sub new {
+ my $class = shift;
+ my %par = @_;
+ my ($host, $port, $classes, $name, $logger, $start_log_listener) =
+ @par{'host','port','classes','name','logger','start_log_listener'};
+ my ($ssl, $ssl_key_file, $ssl_cert_file, $ssl_passwd_cb) =
+ @par{'ssl','ssl_key_file','ssl_cert_file','ssl_passwd_cb'};
+ my ($auth_required, $auth_passwd_href, $auth_module, $loop) =
+ @par{'auth_required','auth_passwd_href','auth_module','loop'};
+ my ($connection_hook, $auto_reload_modules) =
+ @par{'connection_hook','auto_reload_modules'};
+
+ $name ||= "Event-RPC-Server";
+
+ if ( not $loop ) {
+ eval {
+ require Event::RPC::Loop::Event;
+ $loop = Event::RPC::Loop::Event->new;
+ };
+ if ( $@ ) {
+ eval {
+ require Event::RPC::Loop::Glib;
+ $loop = Event::RPC::Loop::Glib->new;
+ };
+ if ( $@ ) {
+ die "It seems neither Event nor Glib are installed";
+ }
+ }
+ }
+
+ my $self = bless {
+ host => $host,
+ port => $port,
+ name => $name,
+ classes => $classes,
+ logger => $logger,
+ start_log_listener => $start_log_listener,
+ loop => $loop,
+
+ ssl => $ssl,
+ ssl_key_file => $ssl_key_file,
+ ssl_cert_file => $ssl_cert_file,
+ ssl_passwd_cb => $ssl_passwd_cb,
+
+ auth_required => $auth_required,
+ auth_passwd_href => $auth_passwd_href,
+ auth_module => $auth_module,
+
+ auto_reload_modules => $auto_reload_modules,
+ connection_hook => $connection_hook,
+
+ rpc_socket => undef,
+ loaded_classes => {},
+ objects => {},
+ logging_clients => {},
+ clients_connected => 0,
+ listeners_started => 0,
+ log_clients_connected => 0,
+ active_connection => undef,
+ }, $class;
+
+ $INSTANCE = $self;
+
+ $self->log ($self->get_name." started");
+
+ return $self;
+}
+
+sub DESTROY {
+ my $self = shift;
+
+ my $rpc_socket = $self->get_rpc_socket;
+ close ($rpc_socket) if $rpc_socket;
+
+ 1;
+}
+
+sub setup_listeners {
+ my $self = shift;
+
+ #-- Listener options
+ my $host = $self->get_host;
+ my $port = $self->get_port;
+ my @LocalHost = $host ? ( LocalHost => $host ) : ();
+ $host ||= "*";
+
+ #-- get event loop manager
+ my $loop = $self->get_loop;
+
+ #-- setup rpc listener
+ my $rpc_socket;
+ if ( $self->get_ssl ) {
+ eval { require IO::Socket::SSL };
+ croak "SSL requested, but IO::Socket::SSL not installed" if $@;
+ croak "ssl_key_file not set" unless $self->get_ssl_key_file;
+ croak "ssl_cert_file not set" unless $self->get_ssl_cert_file;
+
+ $rpc_socket = IO::Socket::SSL->new (
+ Listen => SOMAXCONN,
+ @LocalHost,
+ LocalPort => $port,
+ Proto => 'tcp',
+ ReuseAddr => 1,
+ SSL_verify_mode => 0x00,
+ SSL_key_file => $self->get_ssl_key_file,
+ SSL_cert_file => $self->get_ssl_cert_file,
+ SSL_passwd_cb => $self->get_ssl_passwd_cb,
+ ) or die "can't start SSL RPC listener: $IO::Socket::SSL::ERROR";
+ } else {
+ $rpc_socket = IO::Socket::INET->new (
+ Listen => SOMAXCONN,
+ @LocalHost,
+ LocalPort => $port,
+ Proto => 'tcp',
+ ReuseAddr => 1,
+ ) or die "can't start RPC listener: $!";
+ }
+
+ $self->set_rpc_socket($rpc_socket);
+
+ $loop->add_io_watcher (
+ fh => $rpc_socket,
+ poll => 'r',
+ cb => sub { $self->accept_new_client($rpc_socket); 1 },
+ desc => "rpc listener port $port",
+ );
+
+ if ( $self->get_ssl ) {
+ $self->log ("Started SSL RPC listener on port $host:$port");
+ } else {
+ $self->log ("Started RPC listener on $host:$port");
+ }
+
+ # setup log listener
+ if ( $self->get_start_log_listener ) {
+ my $log_socket = IO::Socket::INET->new (
+ Listen => SOMAXCONN,
+ LocalPort => $port + 1,
+ @LocalHost,
+ Proto => 'tcp',
+ ReuseAddr => 1,
+ ) or die "can't start log listener: $!";
+
+ $loop->add_io_watcher (
+ fh => $log_socket,
+ poll => 'r',
+ cb => sub { $self->accept_new_log_client($log_socket); 1 },
+ desc => "log listener port ".($port+1),
+ );
+
+ $self->log ("Started log listener on $host:".($port+1));
+ }
+
+ $self->set_listeners_started(1);
+
+ 1;
+}
+
+sub setup_auth_module {
+ my $self = shift;
+
+ #-- Exit if no auth is required or setup already
+ return if not $self->get_auth_required;
+ return if $self->get_auth_module;
+
+ #-- Default to Event::RPC::AuthPasswdHash
+ require Event::RPC::AuthPasswdHash;
+
+ #-- Setup an instance
+ my $passwd_href = $self->get_auth_passwd_href;
+ my $auth_module = Event::RPC::AuthPasswdHash->new ($passwd_href);
+ $self->set_auth_module($auth_module);
+
+ 1;
+}
+
+sub start {
+ my $self = shift;
+
+ $self->setup_listeners
+ unless $self->get_listeners_started;
+
+ $self->setup_auth_module;
+
+ my $loop = $self->get_loop;
+
+ $self->log ("Enter main loop using ".ref($loop));
+
+ $loop->enter;
+
+ $self->log ("Server stopped");
+
+ 1;
+}
+
+sub stop {
+ my $self = shift;
+
+ $self->get_loop->leave;
+
+ 1;
+}
+
+sub accept_new_client {
+ my $self = shift;
+ my ($rpc_socket) = @_;
+
+ my $client_socket = $rpc_socket->accept or return;
+
+ Event::RPC::Connection->new ($self, $client_socket);
+
+ $self->set_clients_connected ( 1 + $self->get_clients_connected );
+
+ 1;
+}
+
+sub accept_new_log_client {
+ my $self = shift;
+ my ($log_socket) = @_;
+
+ my $client_socket = $log_socket->accept or return;
+
+ my $log_client =
+ Event::RPC::LogConnection->new($self, $client_socket);
+
+ $self->set_log_clients_connected ( 1 + $self->get_log_clients_connected );
+ $self->get_logging_clients->{$log_client->get_cid} = $log_client;
+ $self->get_logger->add_fh($client_socket)
+ if $self->get_logger;
+
+ $self->log(2, "New log client connected");
+
+ 1;
+}
+
+sub load_class {
+ my $self = shift;
+ my ($class) = @_;
+
+ Event::RPC::Connection->new ($self)->load_class($class);
+
+ return $class;
+}
+
+sub log {
+ my $self = shift;
+ my $logger = $self->get_logger;
+ return unless $logger;
+ $logger->log(@_);
+ 1;
+}
+
+sub remove_object {
+ my $self = shift;
+ my ($object) = @_;
+
+ my $objects = $self->get_objects;
+
+ if ( not $objects->{"$object"} ) {
+ warn "Object $object not registered";
+ return;
+ }
+
+ delete $objects->{"$object"};
+
+ $self->log(5, "Object '$object' removed");
+
+ 1;
+}
+
+sub register_object {
+ my $self = shift;
+ my ($object, $class) = @_;
+
+ my $objects = $self->get_objects;
+
+ my $refcount;
+ if ( $objects->{"$object"} ) {
+ $refcount = ++$objects->{"$object"}->{refcount};
+ } else {
+ $refcount = 1;
+ $objects->{"$object"} = {
+ object => $object,
+ class => $class,
+ refcount => 1,
+ };
+ }
+
+ $self->log(5, "Object '$object' registered. Refcount=$refcount");
+
+ 1;
+}
+
+sub deregister_object {
+ my $self = shift;
+ my ($object) = @_;
+
+ my $objects = $self->get_objects;
+
+ if ( not $objects->{"$object"} ) {
+ warn "Object $object not registered";
+ return;
+ }
+
+ my $refcount = --$objects->{"$object"}->{refcount};
+
+ $self->log(5, "Object '$object' deregistered. Refcount=$refcount");
+
+ $self->remove_object($object) if $refcount == 0;
+
+ 1;
+}
+
+sub print_object_register {
+ my $self = shift;
+
+ print "-"x70,"\n";
+
+ my $objects = $self->get_objects;
+ foreach my $oid ( sort keys %{$objects} ) {
+ print "$oid\t$objects->{$oid}->{refcount}\n";
+ }
+
+ 1;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Event::RPC::Server - Simple API for event driven RPC servers
+
+=head1 SYNOPSIS
+
+ use Event::RPC::Server;
+ use My::TestModule;
+
+ my $server = Event::RPC::Server->new (
+ #-- Required arguments
+ port => 8888,
+ classes => {
+ "My::TestModule" => {
+ new => "_constructor",
+ get_data => 1,
+ set_data => 1,
+ clone => "_object",
+ },
+ },
+
+ #-- Optional arguments
+ name => "Test server",
+ logger => Event::RPC::Logger->new(),
+ start_log_listener => 1,
+
+ ssl => 1
+ ssl_key_file => "server.key",
+ ssl_cert_file => "server.crt",
+ ssl_passwd_cb => sub { "topsecret" },
+
+ auth_required => 1,
+ auth_passwd_href => { $user => Event::RPC->crypt($user,$pass) },
+ auth_module => Your::Own::Auth::Module->new(...),
+
+ loop => Event::RPC::Loop::Event->new(),
+
+ host => "localhost",
+ auto_reload_modules => 1,
+ connection_hook => sub { ... },
+ );
+
+ $server->start;
+
+ # and later from inside your server implementation
+ Event::RPC::Server->instance->stop;
+
+=head1 DESCRIPTION
+
+Use this module to add a simple to use RPC mechanism to your event
+driven server application.
+
+Just create an instance of the Event::RPC::Server class with a
+bunch of required settings. Then enter the main event loop through
+it, or take control over the main loop on your own if you like
+(refer to the MAINLOOP chapter for details).
+
+General information about the architecture of Event::RPC driven
+applications is collected in the Event::RPC manpage.
+
+=head1 CONFIGURATION OPTIONS
+
+All options described here may be passed to the new() constructor of
+Event::RPC::Server. As well you may set or modify them using set_OPTION style
+mutators, but not after start() or setup_listeners() was called!
+All options may be read using get_OPTION style accessors.
+
+=head2 REQUIRED OPTIONS
+
+If you just pass the required options listed beyond you have
+a RPC server which listens to a network port and allows everyone
+connecting to it to access a well defined list of classes and methods
+resp. using the correspondent server objects.
+
+There is no authentication or encryption active in this minimal
+configuration, so aware that this may be a big security risk!
+Adding security is easy, refer to the chapters about SSL and
+authentication.
+
+These are the required options:
+
+=over 4
+
+=item B<port>
+
+TCP port number of the RPC listener.
+
+=item B<classes>
+
+This is a hash ref with the following structure:
+
+ classes => {
+ "Class1" => {
+ new => "_constructor",
+ simple_method => 1,
+ object_returner => "_object",
+ },
+ "Class2" => { ... },
+ ...
+ },
+
+Each class which should be accessable for clients needs to
+be listed here at the first level, assigned a hash of methods
+allowed to be called. Event::RPC disuinguishes three types
+of methods by classifying their return value:
+
+=over 4
+
+=item B<Constructors>
+
+A constructor method creates a new object of the corresponding class
+and returns it. You need to assign the string "_constructor" to
+the method entry to mark a method as a constructor.
+
+=item B<Simple methods>
+
+What's simple about these methods is their return value: it's
+a scalar, array, hash or even any complex reference structure
+(Ok, not simple anymore ;), but in particular it returns B<NO> objects,
+because this needs to handled specially (see below).
+
+Declare simple methods by assigning 1 in the method declaration.
+
+=item B<Object returners>
+
+Methods which return objects need to be declared by assigning
+"_object" to the method name here. They're not bound to return
+just one scalar object reference and may return an array or list
+reference with a bunch of objects as well.
+
+=back
+
+=back
+
+=head2 SSL OPTIONS
+
+The client/server protocol of Event::RPC is not encrypted by default,
+so everyone listening on your network can read or even manipulate
+data. To prevent this efficiently you can enable SSL encryption.
+Event::RPC uses the IO::Socket::SSL Perl module for this.
+
+First you need to generate a server key and certificate for your server
+using the openssl command which is part of the OpenSSL distribution,
+e.g. by issueing these commands (please refer to the manpage of openssl
+for details - this is a very rough example, which works in general, but
+probably you want to tweak some parameters):
+
+ % openssl genrsa -des3 -out server.key 1024
+ % openssl req -new -key server.key -out server.csr
+ % openssl x509 -req -days 3600 -in server.csr \
+ -signkey server.key -out server.crt
+
+After executing these commands you have the following files
+
+ server.crt
+ server.key
+ server.csr
+
+Event::RPC needs the first two of them to operate with SSL encryption.
+
+To enable SSL encryption you need to pass the following options
+to the constructor:
+
+=over 4
+
+=item B<ssl>
+
+The ssl option needs to be set to 1.
+
+=item B<ssl_key_file>
+
+This is the filename of the server.key you generated with
+the openssl command.
+
+=item B<ssl_cert_file>
+
+This is the filename of the server.crt file you generated with
+the openssl command.
+
+=item B<ssl_passwd_cb>
+
+Your server key is encrypted with a password you entered during the
+key creation process described above. This callback must return
+it. Depending on how critical your application is you probably must
+request the password from the user during server startup or place it
+into a more or less secured file. For testing purposes you
+can specify a simple anonymous sub here, which just returns the
+password, e.g.
+
+ ssl_passwd_cb => sub { return "topsecret" }
+
+But note: having the password in plaintext in your program code is
+insecure!
+
+=back
+
+=head2 AUTHENTICATION OPTIONS
+
+SSL encryption is fine, now it's really hard for an attacker to
+listen or modify your network communication. But without any further
+configuration any user on your network is able to connect to your
+server. To prevent this users resp. connections to your server
+needs to be authenticated somehow.
+
+Since version 0.87 Event::RPC has an API to delegate authentication
+tasks to a module, which can be implemented outside Event::RPC.
+To be compatible with prior releases it ships the module
+Event::RPC::AuthPasswdHash which implements the old behaviour
+transparently.
+
+This default implementation is a simple user/password based model. For now
+this controls just the right to connect to your server, so knowing
+one valid user/password pair is enough to access all exported methods
+of your server. Probably a more differentiated model will be added later
+which allows granting access to a subset of exported methods only
+for each user who is allowed to connect.
+
+The following options control the authentication:
+
+=over 4
+
+=item B<auth_required>
+
+Set this to 1 to enable authentication and nobody can connect your server
+until he passes a valid user/password pair.
+
+=item B<auth_passwd_href>
+
+If you like to use the builtin Event::RPC::AuthPasswdHash module
+simply set this attribute. If you decide to use B<auth_module>
+(explained beyound) it's not necessary.
+
+B<auth_passwd_href> is a hash of valid user/password pairs. The password
+stored here needs to be encrypted using Perl's crypt() function, using
+the username as the salt.
+
+Event::RPC has a convenience function for generating such a crypted
+password, although it's currently just a 1:1 wrapper around Perl's
+builtin crypt() function, but probably this changes someday, so better
+use this method:
+
+ $crypted_pass = Event::RPC->crypt($user, $pass);
+
+This is a simple example of setting up a proper B<auth_passwd_href> with
+two users:
+
+ auth_passwd_href => {
+ fred => Event::RPC->crypt("fred", $freds_password),
+ nick => Event::RPC->crypt("nick", $nicks_password),
+ },
+
+=item B<auth_module>
+
+If you like to implement a more complex authentication method yourself
+you may set the B<auth_module> attribute to an instance of your class.
+For now your implementation just needs to have this method:
+
+ $auth_module->check_credentials($user, $pass)
+
+Aware that $pass is encrypted as explained above, so your original
+password needs to by crypted using Event::RPC->crypt as well, at
+least for the comparison itself.
+
+=back
+
+B<Note:> you can use the authentication module without SSL but aware that
+an attacker listening to the network connection will be able to grab
+the encrypted password token and authenticate himself with it to the
+server (replay attack). Probably a more sophisticated challenge/response
+mechanism will be added to Event::RPC to prevent this. But you definitely
+should use SSL encryption in a critical environment anyway, which renders
+grabbing the password from the net impossible.
+
+=head2 LOGGING OPTIONS
+
+Event::RPC has some logging abilities, primarily for debugging purposes.
+It uses a B<logger> for this, which is an object implementing the
+Event::RPC::Logger interface. The documentation of Event::RPC::Logger
+describes this interface and Event::RPC's logging facilities in general.
+
+=over 4
+
+=item B<logger>
+
+To enable logging just pass such an Event::RPC::Logger object to the
+constructor.
+
+=item B<start_log_listener>
+
+Additionally Event::RPC can start a log listener on the server's port
+number incremented by 1. All clients connected to this port (e.g. by
+using telnet) get the server's log output.
+
+Note: currently the logging port supports neither SSL nor authentication,
+so be careful enabling the log listener in critical environments.
+
+=back
+
+=head2 MAINLOOP OPTIONS
+
+Event::RPC derived it's name from the fact that it follows the event
+driven paradigm. There are several toolkits for Perl which allow
+event driven software development. Event::RPC has an abstraction layer
+for this and thus should be able to work with any toolkit.
+
+=over 4
+
+=item B<loop>
+
+This option takes an object of the loop abstraction layer you
+want to use. Currently the following modules are implemented:
+
+ Event::RPC::Loop::Event Use the Event module
+ Event::RPC::Loop::Glib Use the Glib module
+
+If B<loop> isn't set, Event::RPC::Server tries all supported modules
+in a row and aborts the program, if no module was found.
+
+More modules will be added in the future. If you want to implement one
+just take a look at the code in the modules above: it's really
+easy and I appreciate your patch. The interface is roughly described
+in the documentation of Event::RPC::Loop.
+
+=back
+
+If you use the Event::RPC->start() method as described in the SYNOPSIS
+Event::RPC will enter the correspondent main loop for you. If you want
+to have full control over the main loop, use this method to setup
+all necessary Event::RPC listeners:
+
+ $rpc_server->setup_listeners();
+
+and manage the main loop stuff on your own.
+
+=head2 MISCELLANEOUS OPTIONS
+
+=over 4
+
+=item B<host>
+
+By default the network listeners are bound to all interfaces
+in the system. Use the host option to bind to a specific
+interface, e.g. "localhost" if you efficently want to prevent
+network clients from accessing your server.
+
+=item B<auto_reload_modules>
+
+If this option is set Event::RPC::Server will check on each
+method call if the corresponding module changed on disk and
+reloads it automatically. Of course this has an effect on
+performance, but it's very useful during development. You
+probably shouldn't enable this in production environments.
+
+=item B<connection_hook>
+
+This callback is called on each connection / disconnection
+with two arguments: the Event::RPC::Connection object and
+a string containing either "connect" or "disconnect" depending
+what's currently happening with this connection.
+
+=head1 METHODS
+
+The following methods are publically available:
+
+=over 4
+
+=item Event::RPC::Server->B<instance>
+
+This returns the latest created Event::RPC::Server
+instance (usually you have only one instance in one program).
+
+=item $rpc_server->B<start>
+
+Start the mainloop of your Event::RPC::Server.
+
+=item $rpc_server->B<stop>
+
+Stops the mainloop which usually means, that the server exits,
+as long you don't do more sophisticated mainloop stuff by your own.
+
+=item $rpc_server->B<setup_listeners>
+
+This method initializes all networking listeners needed for
+Event::RPC::Server to work, using the configured loop module.
+Use this method if you don't use the start() method but manage
+the mainloop on your own.
+
+=item $rpc_server->B<log> ( [$level,] $msg )
+
+Convenience method for logging. It simply passes the arguments
+to the configured logger's log() method.
+
+=item $rpc_server->B<get_clients_connected>
+
+Returns the number of currently connected Event::RPC clients.
+
+=item $rpc_server->B<get_log_clients_connected>
+
+Returns the number of currently connected logging clients.
+
+=item $rpc_server->B<get_active_connection>
+
+This returns the currently active Event::RPC::Connection object
+representing the connection resp. the client which currently
+requests method invocation. This is undef if no client call
+is active.
+
+=back
+
+=head1 AUTHORS
+
+ Jörn Reder <joern at zyn dot de>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2002-2006 by Jörn Reder.
+
+This library is free software; you can redistribute it and/or modify
+it under the terms of the GNU Library General Public License as
+published by the Free Software Foundation; either version 2.1 of the
+License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Library General Public License for more details.
+
+You should have received a copy of the GNU Library General Public
+License along with this library; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307
+USA.
+
+=cut
Added: packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC.pm
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC.pm 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/lib/Event/RPC.pm 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,177 @@
+package Event::RPC;
+
+$VERSION = "0.89";
+$PROTOCOL = "1.00";
+
+sub crypt {
+ my $class = shift;
+ my ($user, $pass) = @_;
+ return crypt($pass, $user);
+}
+
+__END__
+
+=head1 NAME
+
+Event::RPC - Event based transparent Client/Server RPC framework
+
+=head1 SYNOPSIS
+
+ #-- Server Code
+ use Event::RPC::Server;
+ use My::TestModule;
+ my $server = Event::RPC::Server->new (
+ port => 5555,
+ classes => { "My::TestModule" => { ... } },
+ );
+ $server->start;
+
+ ----------------------------------------------------------
+
+ #-- Client Code
+ use Event::RPC::Client;
+ my $client = Event::RPC::Client->new (
+ server => "localhost",
+ port => 5555,
+ );
+ $client->connect;
+
+ #-- Call methods of My::TestModule on the server
+ my $obj = My::TestModule->new ( foo => "bar" );
+ my $foo = $obj->get_foo;
+
+=head1 ABSTRACT
+
+Event::RPC supports you in developing Event based networking client/server applications with transparent object/method access from the client to the server. Network communication is optionally encrypted using IO::Socket::SSL. Several event loop managers are supported due to an extensible API. Currently Event and Glib are implemented.
+
+=head1 DESCRIPTION
+
+Event::RPC consists of a server and a client library. The server exports a list of classes and methods, which are allowed to be called over the network. More specific it acts as a proxy for objects created on the server side (on demand of the connected clients) which handles client side methods calls with transport of method arguments and return values.
+
+The object proxy handles refcounting and destruction of objects created by clients properly. Objects as method parameters and return values are handled as well (although with some limitations, see below).
+
+For the client the whole thing is totally transparent - once connected to the server it doesn't know whether it calls methods on local or remote objects.
+
+Also the methods on the server newer know whether they are called locally
+or from a connected client. Your application logic is not affected by Event::RPC at all, at least if it has a rudimentary clean OO design.
+
+For details on implementing servers and clients please refer to the man pages of Event::RPC::Server and Event::RPC::Client.
+
+=head1 REQUIREMENTS
+
+Event::RPC needs either one of the following modules on the server
+(they're not necessary on the client):
+
+ Event
+ Glib
+
+They're needed for event handling resp. mainloop implementation.
+If you like to use SSL encryption you need to install
+
+ IO::Socket::SSL
+
+As well Event::RPC makes heavy use of the
+
+ Storable
+
+module, which is part of the Perl standard library. It's important
+that both client and server use B<exactly the same version of the Storable
+module>! Otherwise Event::RPC client/server communication will fail badly.
+
+=head1 INSTALLATION
+
+You get the latest installation tarballs and online documentation
+at this location:
+
+ http://www.exit1.org/Event-RPC/
+
+If your system meets the requirements mentioned above, installation
+is just:
+
+ perl Makefile.PL
+ make test
+ make install
+
+=head1 EXAMPLES
+
+The tarball includes an examples/ directory which contains two
+programs:
+
+ server.pl
+ client.pl
+
+Just execute them with --help to get the usage. They do some very
+simple communication but are good to test your setup, in particular
+in a mixed environment.
+
+=head1 LIMITATIONS
+
+Although the classes and objects on the server are accessed
+transparently by the client there are some limitations should
+be aware of. With a clean object oriented design these should
+be no problem in real applications:
+
+=head2 Direct object data manipulation is forbidden
+
+All objects reside on the server and they keep there! The client
+just has specially wrapped proxy objects, which trigger the
+necessary magic to access the object's B<methods> on the server. Complete
+objects are never transferred from the server to the client,
+so something like this does B<not> work:
+
+ $object->{data} = "changed data";
+
+(assuming $object is a hash ref on the server).
+
+Only method calls are transferred to the server, so even for
+"simple" data manipulation a method call is necessary:
+
+ $object->set_data ("changed data");
+
+As well for reading an object attribute. Accessing a hash
+key will fail:
+
+ my $data = $object->{data};
+
+Instead call a method which returns the 'data' member:
+
+ my $data = $object->get_data;
+
+=head2 Methods may exchange objects, but not in a too complex structure
+
+Event::RPC handles methods which return objects. The only
+requirement is that they are declared as a B<Object returner>
+on the server (refer to Event::RPC::Server for details),
+but not if the object is hided inside a deep complex data structure.
+
+An array or hash ref of objects is Ok, but not more. This
+would require to much expensive runtime data inspection.
+
+Object receiving parameters are more restrictive,
+since even hiding them inside one array or hash ref is not allowed.
+They must be passed as a direkt argument of the method subroutine.
+
+=head1 AUTHORS
+
+ Jörn Reder <joern at zyn dot de>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2002-2006 by Jörn Reder.
+
+This library is free software; you can redistribute it and/or modify
+it under the terms of the GNU Library General Public License as
+published by the Free Software Foundation; either version 2.1 of the
+License, or (at your option) any later version.
+
+This library is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Library General Public License for more details.
+
+You should have received a copy of the GNU Library General Public
+License along with this library; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307
+USA.
+
+=cut
Added: packages/libevent-rpc-perl/branches/upstream/current/t/01.use.t
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/t/01.use.t 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/t/01.use.t 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,6 @@
+use strict;
+use Test::More tests => 2;
+
+use_ok('Event::RPC::Server');
+use_ok('Event::RPC::Client');
+
Added: packages/libevent-rpc-perl/branches/upstream/current/t/02.cnct.t
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/t/02.cnct.t 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/t/02.cnct.t 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,48 @@
+use strict;
+use Test::More;
+
+my $depend_modules = 0;
+eval { require Event } && ++$depend_modules;
+eval { require Glib } && ++$depend_modules;
+
+if ( not $depend_modules ) {
+ plan skip_all => "Neither Event nor Glib installed";
+}
+
+plan tests => 5;
+
+my $PORT = 27811;
+
+# load client class
+use_ok('Event::RPC::Client');
+
+# start server in background, without logging
+require "t/Event_RPC_Test_Server.pm";
+Event_RPC_Test_Server->start_server (
+ p => $PORT,
+ S => 1,
+);
+
+# create client instance
+my $client = Event::RPC::Client->new (
+ host => "localhost",
+ port => $PORT,
+);
+
+# connect to server
+$client->connect;
+ok(1, "connected");
+
+# create instance of test class over RPC
+my $object = Event_RPC_Test->new (
+ data => "Some test data. " x 6
+);
+ok ((ref $object)=~/Event_RPC_Test/, "object created via RPC");
+
+# disconnect client (this will also stop the server,
+# because we started it with the -S option)
+ok ($client->disconnect, "client disconnected");
+
+# wait on server to quit
+wait;
+ok (1, "stop server");
Added: packages/libevent-rpc-perl/branches/upstream/current/t/03.cnct-auth.t
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/t/03.cnct-auth.t 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/t/03.cnct-auth.t 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,61 @@
+use strict;
+
+use Test::More;
+
+my $depend_modules = 0;
+eval { require Event } && ++$depend_modules;
+eval { require Glib } && ++$depend_modules;
+
+if ( not $depend_modules ) {
+ plan skip_all => "Neither Event nor Glib installed";
+}
+
+plan tests => 6;
+
+my $PORT = 27811;
+my $AUTH_USER = "foo";
+my $AUTH_PASS = "bar";
+
+# load client class
+use_ok('Event::RPC::Client');
+
+# start server in background, without logging
+require "t/Event_RPC_Test_Server.pm";
+Event_RPC_Test_Server->start_server (
+ p => $PORT,
+ a => "$AUTH_USER:$AUTH_PASS",
+ S => 2,
+);
+
+# create client instance
+my $client = Event::RPC::Client->new (
+ host => "localhost",
+ port => $PORT,
+ auth_user => $AUTH_USER,
+ auth_pass => "wrong",
+);
+
+# try to connect with wrong password
+eval { $client->connect };
+ok($@ ne '', "connection failed with wrong pw");
+
+# now set correct password
+$client->set_auth_pass(Event::RPC->crypt($AUTH_USER,$AUTH_PASS));
+
+# connect to server with correct password
+$client->connect;
+ok(1, "connected");
+
+# create instance of test class over RPC
+my $object = Event_RPC_Test->new (
+ data => "Some test data. " x 6
+);
+ok ((ref $object)=~/Event_RPC_Test/, "object created via RPC");
+
+# disconnect client (this will also stop the server,
+# because we started it with the -D option)
+ok ($client->disconnect, "client disconnected");
+
+# wait on server to quit
+wait;
+ok (1, "server stopped");
Added: packages/libevent-rpc-perl/branches/upstream/current/t/04.cnct-auth-ssl.t
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/t/04.cnct-auth-ssl.t 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/t/04.cnct-auth-ssl.t 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,67 @@
+use strict;
+
+use Test::More;
+
+my $depend_modules = 0;
+eval { require Event } && ++$depend_modules;
+eval { require Glib } && ++$depend_modules;
+
+if ( not $depend_modules ) {
+ plan skip_all => "Neither Event nor Glib installed";
+}
+
+eval { require IO::Socket::SSL };
+if ( $@ ) {
+ plan skip_all => "IO::Socket::SSL required";
+}
+
+plan tests => 6;
+
+my $PORT = 27811;
+my $AUTH_USER = "foo";
+my $AUTH_PASS = "bar";
+
+# load client class
+use_ok('Event::RPC::Client');
+
+# start server in background, without logging
+require "t/Event_RPC_Test_Server.pm";
+Event_RPC_Test_Server->start_server (
+ p => $PORT,
+ a => "$AUTH_USER:$AUTH_PASS",
+ s => 1,
+ S => 1,
+);
+
+# create client instance
+my $client = Event::RPC::Client->new (
+ host => "localhost",
+ port => $PORT,
+ auth_user => $AUTH_USER,
+ auth_pass => "wrong pass",
+ ssl => 1,
+);
+
+# try to connect with wrong password
+eval { $client->connect };
+ok($@ ne '', "connection failed with wrong pw");
+
+# now set correct password
+$client->set_auth_pass(Event::RPC->crypt($AUTH_USER,$AUTH_PASS));
+
+# connect to server with correct password
+$client->connect;
+ok(1, "connected");
+
+# create instance of test class over RPC
+my $object = Event_RPC_Test->new (
+ data => "Some test data. " x 6
+);
+ok ((ref $object)=~/Event_RPC_Test/, "object created via RPC");
+
+# disconnect client
+ok ($client->disconnect, "client disconnected");
+
+# wait on server to quit
+wait;
+ok (1, "server stopped");
Added: packages/libevent-rpc-perl/branches/upstream/current/t/05.func.t
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/t/05.func.t 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/t/05.func.t 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,104 @@
+use strict;
+use Test::More;
+
+my $depend_modules = 0;
+eval { require Event } && ++$depend_modules;
+eval { require Glib } && ++$depend_modules;
+
+if ( not $depend_modules ) {
+ plan skip_all => "Neither Event nor Glib installed";
+}
+
+plan tests => 16;
+
+my $PORT = 27811;
+
+# load client class
+use_ok('Event::RPC::Client');
+
+# start server in background, without logging
+require "t/Event_RPC_Test_Server.pm";
+Event_RPC_Test_Server->start_server (
+ p => $PORT,
+ S => 1,
+);
+
+# create client instance
+my $client = Event::RPC::Client->new (
+ host => "localhost",
+ port => $PORT,
+);
+
+# count created objects
+my $object_cnt = 0;
+
+# connect to server
+$client->connect;
+ok(1, "connected");
+
+# create instance of test class over RPC
+my $data = "Some test data. " x 6;
+my $object = Event_RPC_Test->new (
+ data => $data
+);
+++$object_cnt;
+ok ((ref $object)=~/Event_RPC_Test/, "object created via RPC");
+
+# test data
+ok ($object->get_data eq $data, "data member ok");
+
+# set data
+ok ($object->set_data("foo") eq "foo", "set data");
+
+# check set data
+ok ($object->get_data eq "foo", "get data");
+
+# object transfer
+my $clone;
+++$object_cnt;
+ok ( $clone = $object->clone, "object transfer");
+
+# check clone
+$clone->set_data("bar");
+ok ( $clone->get_data eq 'bar' &&
+ $object->get_data eq 'foo', "clone");
+
+
+# transfer a list of objects
+my ($lref, $href) = $object->multi(10);
+$object_cnt += 10;
+ok ( @$lref == 10 && $lref->[5]->get_data == 5, "multi object list");
+ok ( keys(%$href) == 10 && $href->{4}->get_data == 4, "multi object hash");
+
+# complex parameter transfer
+my @params = (
+ "scalar", { 1 => "hash" }, [ "a", "list" ],
+);
+
+my @result = $object->echo(@params);
+
+ok ( @result == 3 &&
+ $result[0] eq 'scalar' &&
+ ref $result[1] eq 'HASH' &&
+ $result[1]->{1} eq 'hash' &&
+ ref $result[2] eq 'ARRAY' &&
+ $result[2]->[1] eq 'list'
+ ,
+ "complex parameter transfer"
+);
+
+# get connection cid
+ok ($object->get_cid == 1, "access connection object");
+
+# get client object cnt via connection
+ok ($object->get_object_cnt == $object_cnt, "client object cnt via connection");
+
+# check undef object returner
+ok (!defined $object->get_undef_object, "get undef from an object returner");
+
+# disconnect client
+ok ($client->disconnect, "client disconnected");
+
+# wait on server to quit
+wait;
+ok (1, "server stopped");
Added: packages/libevent-rpc-perl/branches/upstream/current/t/Event_RPC_Test.pm
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/t/Event_RPC_Test.pm 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/t/Event_RPC_Test.pm 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,98 @@
+# $Id: Event_RPC_Test.pm,v 1.3 2006/02/24 14:28:44 joern Exp $
+
+#-----------------------------------------------------------------------
+# Copyright (C) 2002-2005 Jörn Reder <joern AT zyn.de>.
+# All Rights Reserved. See file COPYRIGHT for details.
+#
+# This module is part of Event::RPC, which is free software; you can
+# redistribute it and/or modify it under the same terms as Perl itself.
+#-----------------------------------------------------------------------
+
+package Event_RPC_Test;
+
+use strict;
+
+sub get_data { shift->{data} }
+sub set_data { shift->{data} = $_[1] }
+
+sub new {
+ my $class = shift;
+ my %par = @_;
+ my ($data) = $par{'data'};
+
+ my $self = bless {
+ data => $data,
+ }, $class;
+
+ return $self;
+}
+
+sub hello {
+ my $self = shift;
+
+ return "I hold this data: '".$self->get_data."'";
+}
+
+sub quit {
+ my $self = shift;
+
+ my $rpc_server = Event::RPC::Server->instance;
+
+ $rpc_server->get_loop->add_timer (
+ after => 1,
+ cb => sub { $rpc_server->stop },
+ );
+
+ return "Server stops in one second";
+}
+
+sub clone {
+ my $self = shift;
+
+ my $clone = (ref $self)->new (
+ data => $self->get_data
+ );
+
+ return $clone;
+}
+
+sub multi {
+ my $self = shift;
+ my ($num) = @_;
+
+ my (@list, %hash);
+ while ($num) {
+ push @list, $hash{$num} = (ref $self)->new ( data => $num );
+ --$num;
+ }
+
+ return (\@list, \%hash);
+}
+
+sub echo {
+ my $self = shift;
+ my (@params) = @_;
+ return @params;
+}
+
+sub get_cid {
+ my $self = shift;
+ my $connection = Event::RPC::Server->instance->get_active_connection;
+ my $cid = $connection->get_cid;
+ return $cid;
+}
+
+sub get_object_cnt {
+ my $self = shift;
+ my $connection = Event::RPC::Server->instance->get_active_connection;
+ my $client_oids = $connection->get_client_oids;
+ my $cnt = keys %{$client_oids};
+ return $cnt;
+}
+
+sub get_undef_object {
+ return undef;
+}
+
+1;
+
Added: packages/libevent-rpc-perl/branches/upstream/current/t/Event_RPC_Test_Server.pm
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/t/Event_RPC_Test_Server.pm 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/t/Event_RPC_Test_Server.pm 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,130 @@
+package Event_RPC_Test_Server;
+
+use strict;
+
+use Event::RPC::Server;
+use Event::RPC::Logger;
+use lib qw(t);
+
+sub start_server {
+ my $class = shift;
+ my %opts = @_;
+
+ #-- fork
+ my $server_pid = fork();
+ die "can't fork" unless defined $server_pid;
+
+ #-- client tries to make a log connection to
+ #-- verify that the server is up and running
+ #-- (20 times with a usleep of 0.25, so the
+ #-- overall timeout is 10 seconds)
+ if ( $server_pid ) {
+ for ( 1..20 ) {
+ eval {
+ Event::RPC::Client->log_connect (
+ server => "localhost",
+ port => $opts{p}+1,
+ );
+ };
+ #-- return to client code if connect succeeded
+ return if !$@;
+ #-- bail out if the limit is reached
+ if ( $_ == 20 ) {
+ die "Couldn't start server";
+ }
+ #-- wait a quarter second...
+ select(undef, undef, undef, 0.25);
+ }
+ }
+
+ #-- This code is mainly copied from the server.pl
+ #-- example and works with a command line style
+ #-- %opts hash
+ my %ssl_args;
+ if ( $opts{s} ) {
+ %ssl_args = (
+ ssl => 1,
+ ssl_key_file => 't/ssl/server.key',
+ ssl_cert_file => 't/ssl/server.crt',
+ ssl_passwd_cb => sub { 'eventrpc' },
+ );
+ if ( not -f 't/ssl/server.key' ) {
+ print "please execute from toplevel directory\n";
+ }
+ }
+
+ my %auth_args;
+ if ( $opts{a} ) {
+ my ($user, $pass) = split(":", $opts{a});
+ $pass = Event::RPC->crypt($user, $pass);
+ %auth_args = (
+ auth_required => 1,
+ auth_passwd_href => { $user => $pass },
+ );
+ }
+
+ #-- Create a logger object
+ my $logger = Event::RPC::Logger->new (
+ min_level => (defined $opts{l} ? $opts{l} : 4),
+ fh_lref => [ \*STDOUT ],
+ );
+
+ #-- Create a loop object
+ my $loop;
+ my $loop_module = $opts{L};
+ if ( $loop_module ) {
+ eval "use $loop_module";
+ die $@ if $@;
+ $loop = $loop_module->new();
+ }
+
+ my $port = $opts{p} || 5555;
+
+ my $disconnect_cnt = $opts{S};
+
+ #-- Create a Server instance and declare the
+ #-- exported interface
+ my $server;
+ $server = Event::RPC::Server->new (
+ name => "test daemon",
+ port => $port,
+# logger => $logger,
+ loop => $loop,
+ start_log_listener => 1,
+ %auth_args,
+ %ssl_args,
+ classes => {
+ 'Event_RPC_Test' => {
+ new => '_constructor',
+ set_data => 1,
+ get_data => 1,
+ hello => 1,
+ quit => 1,
+ clone => '_object',
+ multi => '_object',
+ echo => 1,
+ get_cid => 1,
+ get_object_cnt => 1,
+ get_undef_object => '_object',
+ },
+ },
+ connection_hook => sub {
+ my ($conn, $event) = @_;
+ return if $event eq 'connect';
+ --$disconnect_cnt;
+ $server->stop
+ if $disconnect_cnt <= 0 &&
+ $server->get_clients_connected == 0;
+ 1;
+ },
+ );
+
+ #-- Start the server resp. the Event loop.
+ $server->start;
+
+ #-- Exit the program
+ exit;
+}
+
+1;
+
Property changes on: packages/libevent-rpc-perl/branches/upstream/current/t/Event_RPC_Test_Server.pm
___________________________________________________________________
Name: svn:executable
+
Added: packages/libevent-rpc-perl/branches/upstream/current/t/ssl/server.crt
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/t/ssl/server.crt 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/t/ssl/server.crt 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,17 @@
+-----BEGIN CERTIFICATE-----
+MIICozCCAgwCCQC7s/EOvPkeSTANBgkqhkiG9w0BAQQFADCBlTELMAkGA1UEBhMC
+REUxETAPBgNVBAgTCElyZ2VuZHdvMQ4wDAYDVQQHEwVLb2VsbjESMBAGA1UEChMJ
+ZXhpdDEub3JnMR0wGwYDVQQLExRTb2Z0d2FyZSBEZXZlbG9wbWVudDETMBEGA1UE
+AxQKSvZybiBSZWRlcjEbMBkGCSqGSIb3DQEJARYMam9lcm5AenluLmRlMB4XDTA1
+MDMxMzE3NDg1NloXDTE1MDEyMDE3NDg1NlowgZUxCzAJBgNVBAYTAkRFMREwDwYD
+VQQIEwhJcmdlbmR3bzEOMAwGA1UEBxMFS29lbG4xEjAQBgNVBAoTCWV4aXQxLm9y
+ZzEdMBsGA1UECxMUU29mdHdhcmUgRGV2ZWxvcG1lbnQxEzARBgNVBAMUCkr2cm4g
+UmVkZXIxGzAZBgkqhkiG9w0BCQEWDGpvZXJuQHp5bi5kZTCBnzANBgkqhkiG9w0B
+AQEFAAOBjQAwgYkCgYEApKvgMocsWLb3SQw1UukxcCORSDYgge1d1LAGIPlRtLRh
+CCNfUufY8Jslmn/4hZI4wpeRQ5M2NLMkP8kaCgmMviyl20I+jCikLqQFTTMmwU35
+uWoMw343kZA4G6eLqjWVy8NHNABTthgigHaVGWld0lRFpYD4DcWIze50Afg8dl8C
+AwEAATANBgkqhkiG9w0BAQQFAAOBgQAaahVlE9jXt0GO+Zk9ZDUmyiLQ31lhRbvr
+/fFqLYB3WS0xGnKKaj3IQFREkke7an4rhUaZLGstAhF3bXcN//t9bgZKQfnRPsM2
+bQHEVWAtwjebv0Rn0uR53gZBxoCHZyGwCL0Tj0Gvynpou4Y8UDGnfc1E/r+HOTCO
+yvVrQL359w==
+-----END CERTIFICATE-----
Added: packages/libevent-rpc-perl/branches/upstream/current/t/ssl/server.csr
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/t/ssl/server.csr 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/t/ssl/server.csr 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,12 @@
+-----BEGIN CERTIFICATE REQUEST-----
+MIIB1jCCAT8CAQAwgZUxCzAJBgNVBAYTAkRFMREwDwYDVQQIEwhJcmdlbmR3bzEO
+MAwGA1UEBxMFS29lbG4xEjAQBgNVBAoTCWV4aXQxLm9yZzEdMBsGA1UECxMUU29m
+dHdhcmUgRGV2ZWxvcG1lbnQxEzARBgNVBAMUCkr2cm4gUmVkZXIxGzAZBgkqhkiG
+9w0BCQEWDGpvZXJuQHp5bi5kZTCBnzANBgkqhkiG9w0BAQEFAAOBjQAwgYkCgYEA
+pKvgMocsWLb3SQw1UukxcCORSDYgge1d1LAGIPlRtLRhCCNfUufY8Jslmn/4hZI4
+wpeRQ5M2NLMkP8kaCgmMviyl20I+jCikLqQFTTMmwU35uWoMw343kZA4G6eLqjWV
+y8NHNABTthgigHaVGWld0lRFpYD4DcWIze50Afg8dl8CAwEAAaAAMA0GCSqGSIb3
+DQEBBAUAA4GBAJmfq2IqvN+m9IIRzNTHBjEaOeYIEFVKcqWIiui/hvw8M7Yi0op2
+ifOjRKSfYTsgNAst1Ilwg6wgblSngg6f9GpGtWAYr1xQpoWS8PDaqjx1sLE40qi2
+aNrCtrSCLxzLh9o0qeUydcrjvIK6sWe6lGRntjNoj2VCqlBm0EFQ7vNF
+-----END CERTIFICATE REQUEST-----
Added: packages/libevent-rpc-perl/branches/upstream/current/t/ssl/server.key
===================================================================
--- packages/libevent-rpc-perl/branches/upstream/current/t/ssl/server.key 2006-04-13 22:37:18 UTC (rev 2571)
+++ packages/libevent-rpc-perl/branches/upstream/current/t/ssl/server.key 2006-04-15 18:15:22 UTC (rev 2572)
@@ -0,0 +1,18 @@
+-----BEGIN RSA PRIVATE KEY-----
+Proc-Type: 4,ENCRYPTED
+DEK-Info: DES-EDE3-CBC,CEB8A2E7F9C59066
+
+mUDYr4fgc2lba+qobTYxcq/8ZpRS1cdoiCe1QQeSQ2Bywrsgx8H40hqkBsKOYBPa
+ZFC+EEQTfhGOswTD5YsgqfTyWc7w0qlXDlPCVgV28r96gKzpP6oEDoclriWsToDF
+ZOsANyGcdl4D4VyY+oOf9crUFqIC4C/IfUJ++pZCUlGy8k/J0qHl/kCEP1bPg92q
+tKrG/gcDtrqnVHYB22MruAXHSAo4JOO7A6ZmrRGH4XY5SKGZPF/T7kwLLzEXbPq2
+MDrcPg3xWcCvODswrptdmK73PyF5oWkA7NXAofecu51jW1Y9G48p1lQi0mAgP3qP
+LDxCFQUU52G9UAxmfd8pZBSntRIsaIQV+6ffM8TemObgf1VkisCGDUCnEgvj2zDN
+AaieLhR4MKIQuYZSTLfCI5mKZK0vCFP5t19wK6Clt7p9bq1aUu8HkqEZ5yrNmf04
+acKvUkDbVCPL1pkAsyNAEQ4Zs3f3VxkuRrtf7gqzEEFK1TQoH7JmaALqGftgkPYJ
+eEYX8Om/Gr8NxTftSNbnoaFUyeoBOQ1iZY2g4qqE0rZlc7lfXiXAV3ajtgPcreZa
++uU4g8DF7zfQ7F8FK7w2ryLJFdlgk7SzEjv1VzCQTQ2MjBOCs0gJ3SPF6wx6lfyH
+9HqYRu2OwPJlaTzVrdhwKesROuBr1+rJym18uvzObSgkbTrFQuuYcR0dNbs+AuqQ
+dkhOC6bzpOdZNWVnVQ7klbsj8iUSMs4QnSI0+DpSls5VOMJiAXqPCAy4YJ0GAcGv
+EDF12ONiToyGb0Jolo+WOXyDebHR19TxokTcC5Ri7305mtRAP7g1fQ==
+-----END RSA PRIVATE KEY-----
More information about the Pkg-perl-cvs-commits
mailing list