Commit 53955f50 authored by Robert Ricci's avatar Robert Ricci

Perl module for the event system.

This is accomplished with SWIG, so that we can basically just call the
C functions from perl, and avoid a parllel implementation. Some glue
code is required, particularly for callbacks, macros, and functions
that return data through arguments.

Currently lacks support for a few functions, but is functional enough
to re-write the example C programs.
parent 95a96d83
This is the documentation for the Perl API to the event system...
Theoretically, most event library calls should 'just work.' See the lists below
to see which have been tested, and which are known not to work. SWIG does not
grok macros -- some have been 'translated' into regular functions, but not all.
Note that you don't get any magic perl garbage collection, etc, for C objects.
So, you still have to call address_tuple_alloc/address_tuple_free, etc.
Also, SWIG modules do not export functions. This means that you have to either
prefix everthing with 'event::' (cumbersome, since most event system stuff
starts with 'event_' already), or cheat, by putting yourself in the module's
namespace with the line 'package event;'
Examples of the use of the perl event system are in the examples/ directory,
and mirror the C examples.
The following functions have been tested, and the same as their C counterparts:
address_tuple_alloc
address_tuple_free
event_notification_alloc
event_notification_clone
event_notification_free
event_notify
event_unregister
event_subscribe
event_poll
event_notification_put_string (put_* should work)
The following functions have changed slightly, or have caveats:
event_register - Works fine, but DO NOT pass anything but 0 as the second
argument (no threading support)
event_notification_get_string - Rather than taking a string reference and
length, just returns a string. Returns undef if it can't find the
string in the notification. This also goes for all macros based on
this function
The following functions do NOT work:
event_main - Only polling is avialable at this point, due to the glue we have
to use to get callbacks to work
event_notification_get_* (except string) - Return arguments are somewhat
problematic. Shouldn't be too hard to implement, but there seemed no
immedeate need (since strings are the bits we use the most.)
#!/usr/bin/perl
#
# This is a sample client to run on a testbed node to capture TBEXAMPLE
# events for the node. Perl equivalent of tbrecv.c
#
#
# Configure variables
#
use lib '@prefix@/lib';
use event;
package event; # Laziness so that we don't have to specify package name
use Getopt::Std;
use strict;
sub usage {
warn "Usage: $0 [-s server] [-p port] <event>\n";
return 1;
}
my %opt = ();
getopt(\%opt,"s:p:h");
if ($opt{h}) { exit &usage; }
if (@ARGV) { exit &usage; }
my ($server,$port);
if ($opt{s}) { $server = $opt{s}; } else { $server = "boss"; }
if ($opt{p}) { $port = $opt{p}; }
my $URL = "elvin://$server";
if ($port) { $URL .= ":$port"; }
my $handle = event_register($URL,0);
if (!$handle) { die "Unable to register with event system\n"; }
my $tuple = address_tuple_alloc();
if (!$tuple) { die "Could not allocate an address tuple\n"; }
%$tuple = ( host => $event::ADDRESSTUPLE_ALL,
objtype => 'TBEXAMPLE' );
if (!event_subscribe($handle,\&callbackFunc,$tuple)) {
die "Could not subscribe to event\n";
}
#
# Note a difference from tbrecv.c - we don't yet have event_main() functional
# in perl, so we have to poll. (Nothing special about the select, it's just
# a wacky way to get usleep() )
#
while (1) {
event_poll($handle);
select(undef, undef, undef, 0.25);
}
if (event_unregister($handle) == 0) {
die "Unable to unregister with event system\n";
}
exit(0);
sub callbackFunc($$$) {
my ($handle,$notification,$data) = @_;
my $time = time();
my $site = event_notification_get_site($handle, $notification);
my $expt = event_notification_get_expt($handle, $notification);
my $group = event_notification_get_group($handle, $notification);
my $host = event_notification_get_host($handle, $notification);
my $objtype = event_notification_get_objtype($handle, $notification);
my $objname = event_notification_get_objname($handle, $notification);
my $eventtype = event_notification_get_eventtype($handle,
$notification);
print "Event: $time $site $expt $group $host $objtype $objname " .
"$eventtype\n";
exit(0);
}
#!/usr/bin/perl
#
# This is a sample event generator to send TBEXAMPLE events to all nodes
# in an experiment. Perl equivalent of tbsend.c
#
#
# Configure variables
#
use lib '@prefix@/lib';
use event;
package event; # Laziness so that we don't have to specify package name
use Getopt::Std;
use strict;
sub usage {
warn "Usage: $0 [-s server] [-p port] <event>\n";
return 1;
}
my %opt = ();
getopt(\%opt,"s:p:h");
if ($opt{h}) { exit &usage; }
if (@ARGV != 1) { exit &usage; }
my ($server,$port);
if ($opt{s}) { $server = $opt{s}; } else { $server = "boss"; }
if ($opt{p}) { $port = $opt{p}; }
my $URL = "elvin://$server";
if ($port) { $URL .= ":$port"; }
my $handle = event_register($URL,0);
if (!$handle) { die "Unable to register with event system\n"; }
my $tuple = address_tuple_alloc();
if (!$tuple) { die "Could not allocate an address tuple\n"; }
%$tuple = ( objtype => "TBEXAMPLE",
eventtype => $ARGV[0],
host => "*");
my $notification = event_notification_alloc($handle,$tuple);
if (!$notification) { die "Could not allocate notification\n"; }
print "Sent at time " . time() . "\n";
if (!event_notify($handle, $notification)) {
die("could not send test event notification");
}
event_notification_free($handle, $notification);
if (event_unregister($handle) == 0) {
die("could not unregister with event system");
}
exit(0);
......@@ -5,7 +5,7 @@ SUBDIR = event/lib
include $(OBJDIR)/Makeconf
all: libevent.a libevent_r.a
all: libevent.a libevent_r.a event.so
include $(TESTBED_SRCDIR)/GNUmakerules
......@@ -13,6 +13,8 @@ include $(TESTBED_SRCDIR)/GNUmakerules
CFLAGS += -O -g -static -I. -Wall -I$(TESTBED_SRCDIR)/lib/libtb
CFLAGS += `elvin-config --cflags vin4mt`
LDFLAGS += -L${OBJDIR}/lib/libtb
OBJS = event.o util.o
POBJS = event_r.o util.o
......@@ -30,7 +32,24 @@ $(POBJS): event.h
event_r.o: event.c
$(CC) $(CFLAGS) -DTHREADED -c -o event_r.o $<
install:
#
# These three targets are for the perl binding to the event system
#
event_wrap.c: event.i event.c event.pm.tail
swig -dnone -perl5 -shadow -I$(SRCDIR) $(SRCDIR)/event.i
cat $(SRCDIR)/event.pm.tail >> event.pm
event_wrap.o: $(SRCDIR)/event_wrap.c
$(CC) -c $(CFLAGS) -I/usr/libdata/perl/5.00503/mach/CORE $<
event.so: event.o event_wrap.o util.o
ld -shared $^ $(OBJDIR)/lib/libtb/libtb.a \
`elvin-config --libs vin4c` -o event.so
LIB_STUFF = event.pm event.so
install: $(addprefix $(INSTALL_LIBDIR)/, $(LIB_STUFF))
clean:
/bin/rm -f *.o libevent.a
/bin/rm -f *.o libevent.a *.so *.pm
/*
* event.i - SWIG interface file for the Testbed event systems
*/
%module event
%{
#define NO_EVENT_MACROS
#include "event.h"
%}
/*
* Rename the C event_subscribe() and event_poll(), so that we can replace
* these with perl functions of the same name.
*/
%rename event_subscribe c_event_subscribe;
%rename event_poll c_event_poll;
/*
* We have to replace this one, because it works in a way very foreign to
* perl. We write our own version below.
*/
%rename event_notification_get_string c_event_notification_get_string;
/*
* Prevent anyone from using this function
*/
%rename event_main dont_use_this_function_because_it_does_not_work;
/*
* Simply allow access to everything in event.h
*
* NOTE: not all event functions have been well-tested in perl!!!
*/
%echo "*** Warnings about function pointers can be ignored"
%include "event.h"
/*
* Glue needed to support callbacks under perl
*/
%inline %{
/*
* Set to 1 by the stub callback below if a notification is ready to be
* processed by a callback.
*/
int callback_ready;
/*
* Set when callback_ready is also set
*/
event_notification_t callback_notification;
/*
* Stub callback that simply sets callback_ready and
* callback_notification
*/
void perl_stub_callback(event_handle_t handle,
event_notification_t notification, void *data) {
callback_ready = 1;
callback_notification = event_notification_clone(handle,
notification);
if (!callback_notification) {
/*
* event_notification_clone will have already reported
* an error message, so we don't have to again
*/
callback_ready = 0;
}
}
/*
* Call event_subscribe using the stub function
*/
event_subscription_t stub_event_subscribe(event_handle_t handle,
address_tuple_t tuple) {
return event_subscribe(handle,perl_stub_callback,tuple,NULL);
}
%}
/*
* Wrappers for return-argument functions
*/
%rename perl_event_notification_get_string event_notification_get_string;
%inline %{
/*
* We use a global buffer to avoid leaking memory - SWIG/XS/perl
* will take the return value of char* functions and convert them
* to perl strings, which makes a copy of the string. So, if we
* return malloc()ed memory, it gets leaked. But, the event system
* requires us to pass in a buffer to fill....
*/
char event_string_buffer[1024];
char *perl_event_notification_get_string(event_handle_t handle,
event_notification_t notification, char *name) {
int rv;
rv = event_notification_get_string(handle,notification,name,
event_string_buffer,sizeof(event_string_buffer));
if (!rv) {
return NULL;
} else {
return event_string_buffer;
}
}
%}
/*
* 'macros' - Since SWIG doesn't grok macros, these are here to get the
* same functionality (we could do this in event.h, but I didn't want to
* rock the boat too much.) Also, we get a chance to put them in a more
* perl-friendly format.
*/
%inline %{
char *event_notification_get_site(event_handle_t handle,
event_notification_t note) {
return perl_event_notification_get_string(handle,note,"SITE");
}
char* event_notification_get_expt(event_handle_t handle,
event_notification_t note) {
return perl_event_notification_get_string(handle,note,"EXPT");
}
char* event_notification_get_group(event_handle_t handle,
event_notification_t note) {
return perl_event_notification_get_string(handle,note,"GROUP");
}
char *event_notification_get_host(event_handle_t handle,
event_notification_t note) {
return perl_event_notification_get_string(handle,note,"HOST");
}
char *event_notification_get_objtype(event_handle_t handle,
event_notification_t note) {
return perl_event_notification_get_string(handle,note,
"OBJTYPE");
}
char *event_notification_get_objname(event_handle_t handle,
event_notification_t note) {
return perl_event_notification_get_string(handle,note,
"OBJNAME");
}
char* event_notification_get_eventtype(event_handle_t handle,
event_notification_t note) {
return perl_event_notification_get_string(handle,note,
"EVENTTYPE");
}
char* event_notification_get_arguments(event_handle_t handle,
event_notification_t note) {
return perl_event_notification_get_string(handle,note,"ARGS");
}
int event_notification_set_arguments(event_handle_t handle,
event_notification_t note, char *buf) {
return event_notification_put_string(handle,note,"ARGS", buf);
}
char *event_notification_get_sender(event_handle_t handle,
event_notification_t note) {
return perl_event_notification_get_string(handle,note,
"___SENDER___");
}
int event_notification_set_sender(event_handle_t handle,
event_notification_t note, char *buf) {
return event_notification_put_string(handle,note,
"___SENDER___",buf);
}
%}
#
# CODE PAST THIS POINT WAS NOT AUTOMATICALLY GENERATED BY SWIG
#
# For now, this has to get cat'ed onto the end of event.pm, since it
# doesn't seem possible to get SWIG to just pass it through into the
# output file
#
#
# Stash away the given callback and data, and call the C event_subscribe
# function that uses a stub callback
#
sub event_subscribe($$$;$) {
my ($handle,$function,$tuple,$data) = @_;
$event::callback = $function;
$event::callback_data = $data;
return stub_event_subscribe($handle,$tuple);
}
#
# Clear $callback_ready, call the C event_poll function, and see if the
# C callback got called (as evidenced by $callback_ready getting set) If it
# did, call the perl callback function.
#
sub event_poll($) {
my $handle = shift;
$event::callback_ready = 0;
my $rv = c_event_poll($handle);
if ($rv) {
die "Trouble in event_poll - returned $rv\h";
}
if ($event::callback_ready) {
&$event::callback($handle,$event::callback_notification,
$event::callback_data);
event_notification_free($handle,$event::callback_notification);
}
return 0;
}
1;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment