Commit fccf4efd authored by Robert Ricci's avatar Robert Ricci

Add the new blocking poll the the perl libraries.

parent 1b38c7d1
......@@ -14,11 +14,12 @@
%}
/*
* Rename the C event_subscribe() and event_poll(), so that we can replace
* these with perl functions of the same name.
* Rename the C event_subscribe(), event_poll(), and event_poll_blocking(), 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;
%rename event_poll_blocking c_event_poll_blocking;
/*
* We have to replace this one, because it works in a way very foreign to
......
......@@ -3,7 +3,7 @@ package event;
require Exporter;
require DynaLoader;
@ISA = qw(Exporter DynaLoader);
@EXPORT = qw(address_tuple_alloc address_tuple_free event_register event_unregister c_event_poll dont_use_this_function_because_it_does_not_work event_notify event_schedule event_notification_alloc event_notification_free event_notification_clone event_notification_get_double event_notification_get_int32 event_notification_get_int64 event_notification_get_opaque c_event_notification_get_string event_notification_put_double event_notification_put_int32 event_notification_put_int64 event_notification_put_opaque event_notification_put_string event_notification_remove c_event_subscribe xmalloc xrealloc allocate_callback_data free_callback_data dequeue_callback_data enqueue_callback_data perl_stub_callback stub_event_subscribe event_notification_get_string event_notification_get_site event_notification_get_expt event_notification_get_group event_notification_get_host event_notification_get_objtype event_notification_get_objname event_notification_get_eventtype event_notification_get_arguments event_notification_set_arguments event_notification_get_sender event_notification_set_sender event_handle_server_set event_handle_server_get event_handle_status_set event_handle_status_get address_tuple_site_set address_tuple_site_get address_tuple_expt_set address_tuple_expt_get address_tuple_group_set address_tuple_group_get address_tuple_host_set address_tuple_host_get address_tuple_objtype_set address_tuple_objtype_get address_tuple_objname_set address_tuple_objname_get address_tuple_eventtype_set address_tuple_eventtype_get address_tuple_scheduler_set address_tuple_scheduler_get callback_data_callback_notification_set callback_data_callback_notification_get callback_data_next_set callback_data_next_get );
@EXPORT = qw(address_tuple_alloc address_tuple_free event_register event_unregister c_event_poll c_event_poll_blocking dont_use_this_function_because_it_does_not_work event_notify event_schedule event_notification_alloc event_notification_free event_notification_clone event_notification_get_double event_notification_get_int32 event_notification_get_int64 event_notification_get_opaque c_event_notification_get_string event_notification_put_double event_notification_put_int32 event_notification_put_int64 event_notification_put_opaque event_notification_put_string event_notification_remove c_event_subscribe xmalloc xrealloc allocate_callback_data free_callback_data dequeue_callback_data enqueue_callback_data perl_stub_callback stub_event_subscribe event_notification_get_string event_notification_get_site event_notification_get_expt event_notification_get_group event_notification_get_host event_notification_get_objtype event_notification_get_objname event_notification_get_eventtype event_notification_get_arguments event_notification_set_arguments event_notification_get_sender event_notification_set_sender event_handle_server_set event_handle_server_get event_handle_status_set event_handle_status_get address_tuple_site_set address_tuple_site_get address_tuple_expt_set address_tuple_expt_get address_tuple_group_set address_tuple_group_get address_tuple_host_set address_tuple_host_get address_tuple_objtype_set address_tuple_objtype_get address_tuple_objname_set address_tuple_objname_get address_tuple_eventtype_set address_tuple_eventtype_get address_tuple_scheduler_set address_tuple_scheduler_get callback_data_callback_notification_set callback_data_callback_notification_get callback_data_next_set callback_data_next_get );
package eventc;
bootstrap event;
var_event_init();
......@@ -63,6 +63,12 @@ sub c_event_poll {
my $result = eventc::c_event_poll(@args);
return $result;
}
sub c_event_poll_blocking {
my @args = @_;
$args[0] = tied(%{$args[0]});
my $result = eventc::c_event_poll_blocking(@args);
return $result;
}
sub dont_use_this_function_because_it_does_not_work {
my @args = @_;
$args[0] = tied(%{$args[0]});
......@@ -526,12 +532,19 @@ sub event_subscribe($$$;$) {
#
# 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.
# did, call the perl callback function. Handle both blocking and non-blocking
# versions of the call
#
sub event_poll($) {
my $handle = shift;
sub internal_event_poll($$$) {
my ($handle, $block, $timeout) = @_;
my $rv;
if ($block) {
$rv = c_event_poll_blocking($handle,$timeout);
} else {
$rv = c_event_poll($handle);
}
my $rv = c_event_poll($handle);
if ($rv) {
die "Trouble in event_poll - returned $rv\h";
}
......@@ -546,6 +559,22 @@ sub event_poll($) {
return 0;
}
#
# Wrapper for the internal polling function, non-blocking version
#
sub event_poll($) {
my $handle = shift;
return &internal_event_poll($handle,0,0);
}
#
# Same as above, but for the blocking version
#
sub event_poll_blocking($$) {
my ($handle, $timeout) = @_;
return &internal_event_poll($handle,1,$timeout);
}
#
# NOTE: The following line will only work if this module is included by
# a file that has already done a 'use lib' to get the path to testbed
......@@ -689,7 +718,7 @@ END {
}
}
push @EXPORT, qw(event_subscribe event_poll EventSend EventSendFatal
EventSendWarn);
push @EXPORT, qw(event_subscribe event_poll event_poll_blocking EventSend
EventSendFatal EventSendWarn);
1;
......@@ -20,12 +20,19 @@ sub event_subscribe($$$;$) {
#
# 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.
# did, call the perl callback function. Handle both blocking and non-blocking
# versions of the call
#
sub event_poll($) {
my $handle = shift;
sub internal_event_poll($$$) {
my ($handle, $block, $timeout) = @_;
my $rv;
if ($block) {
$rv = c_event_poll_blocking($handle,$timeout);
} else {
$rv = c_event_poll($handle);
}
my $rv = c_event_poll($handle);
if ($rv) {
die "Trouble in event_poll - returned $rv\h";
}
......@@ -40,6 +47,22 @@ sub event_poll($) {
return 0;
}
#
# Wrapper for the internal polling function, non-blocking version
#
sub event_poll($) {
my $handle = shift;
return &internal_event_poll($handle,0,0);
}
#
# Same as above, but for the blocking version
#
sub event_poll_blocking($$) {
my ($handle, $timeout) = @_;
return &internal_event_poll($handle,1,$timeout);
}
#
# NOTE: The following line will only work if this module is included by
# a file that has already done a 'use lib' to get the path to testbed
......@@ -183,7 +206,7 @@ END {
}
}
push @EXPORT, qw(event_subscribe event_poll EventSend EventSendFatal
EventSendWarn);
push @EXPORT, qw(event_subscribe event_poll event_poll_blocking EventSend
EventSendFatal EventSendWarn);
1;
/*
* FILE : /users/ricci/testbed/event/lib/event_wrap.c
* FILE : /home/ricci/testbed/event/lib/event_wrap.c
*
* This file was automatically generated by :
* Simplified Wrapper and Interface Generator (SWIG)
......@@ -62,7 +62,7 @@ extern "C" {
/*****************************************************************************
* $Header: /home/cvs_mirrors/cvs-public.flux.utah.edu/CVS/testbed/event/lib/event_wrap.c,v 1.3 2002-04-02 23:29:44 ricci Exp $
* $Header: /home/cvs_mirrors/cvs-public.flux.utah.edu/CVS/testbed/event/lib/event_wrap.c,v 1.4 2003-02-28 02:10:33 ricci Exp $
*
* perl5ptr.swg
*
......@@ -96,8 +96,8 @@ extern "C" {
* SWIGSTATIC.
*
* $Log: event_wrap.c,v $
* Revision 1.3 2002-04-02 23:29:44 ricci
* Somehow, this file didn't get committed with my last commit.
* Revision 1.4 2003-02-28 02:10:33 ricci
* Add the new blocking poll the the perl libraries.
*
* Revision 1.1 1996/12/26 22:17:29 beazley
* Initial revision
......@@ -501,8 +501,8 @@ static void _swig_setpv(CPerl *pPerl, char *name, char *value) {
}
/*
* Stub callback that simply sets callback_ready and
* callback_notification
* Stub callback that simply pushes a new entry onto the list
* of data for the perl callback function
*/
void perl_stub_callback(event_handle_t handle,
event_notification_t notification, void *data) {
......@@ -756,6 +756,28 @@ XS(_wrap_c_event_poll) {
XSRETURN(argvi);
}
XS(_wrap_c_event_poll_blocking) {
int _result;
event_handle_t _arg0;
unsigned int _arg1;
int argvi = 0;
dXSARGS ;
cv = cv;
if ((items < 2) || (items > 2))
croak("Usage: c_event_poll_blocking(handle,timeout);");
if (SWIG_GetPtr(ST(0),(void **) &_arg0,"event_handle")) {
croak("Type error in argument 1 of c_event_poll_blocking. Expected event_handle.");
XSRETURN(1);
}
_arg1 = (unsigned int )SvIV(ST(1));
_result = (int )event_poll_blocking(_arg0,_arg1);
ST(argvi) = sv_newmortal();
sv_setiv(ST(argvi++),(IV) _result);
XSRETURN(argvi);
}
XS(_wrap_dont_use_this_function_because_it_does_not_work) {
int _result;
......@@ -2360,6 +2382,7 @@ XS(boot_event) {
newXS("eventc::event_register", _wrap_event_register, file);
newXS("eventc::event_unregister", _wrap_event_unregister, file);
newXS("eventc::c_event_poll", _wrap_c_event_poll, file);
newXS("eventc::c_event_poll_blocking", _wrap_c_event_poll_blocking, file);
newXS("eventc::dont_use_this_function_because_it_does_not_work", _wrap_dont_use_this_function_because_it_does_not_work, file);
newXS("eventc::event_notify", _wrap_event_notify, file);
newXS("eventc::event_schedule", _wrap_event_schedule, file);
......
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