[libnet-dbus-perl] 03/335: More functionality; general cleanup; lots of POD docs
Intrigeri
intrigeri at moszumanska.debian.org
Sat Mar 21 01:07:09 UTC 2015
This is an automated email from the git hooks/post-receive script.
intrigeri pushed a commit to branch experimental
in repository libnet-dbus-perl.
commit ac43d138f1a4bacae5919ff36eed0ecbf1479bcd
Author: Daniel P. Berrange <dan at berrange.com>
Date: Mon Aug 9 21:47:18 2004 +0000
More functionality; general cleanup; lots of POD docs
---
DBus.xs | 533 +++++++++++++++++++++++++++++++---------
MANIFEST.SKIP | 10 +
Makefile.PL | 40 ++-
README | 110 +++++++--
lib/DBus.pm | 8 +-
lib/DBus/Callback.pm | 42 ++++
lib/DBus/Connection.pm | 358 ++++++++++++++++++++++++++-
lib/DBus/Iterator.pm | 137 ++++++++++-
lib/DBus/Message.pm | 21 +-
lib/DBus/Message/Error.pm | 4 +-
lib/DBus/Reactor.pm | 606 ++++++++++++++++++++++++++++++++++++++++++----
lib/DBus/Server.pm | 132 ++++++++--
rollingbuild.sh | 21 ++
typemap | 22 +-
14 files changed, 1816 insertions(+), 228 deletions(-)
diff --git a/DBus.xs b/DBus.xs
index 8c20349..b7393b2 100644
--- a/DBus.xs
+++ b/DBus.xs
@@ -1,23 +1,54 @@
+
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include <dbus/dbus.h>
+#if PD_DO_DEBUG
+#define PD_DEBUG(...) if (getenv("PD_DEBUG")) fprintf(stderr, __VA_ARGS__)
+#else
+#define PD_DEBUG(...)
+#endif
+
+
+/* The -1 is required by the contract for
+ dbus_{server,connection}_allocate_slot
+ initialization */
+dbus_int32_t connection_data_slot = -1;
+dbus_int32_t server_data_slot = -1;
+
+void
+_object_release(void *obj) {
+ PD_DEBUG("Releasing object count on %x\n", obj);
+ SvREFCNT_dec((SV*)obj);
+}
dbus_bool_t
-_watch_generic(DBusWatch *watch, void *data, char *key) {
- HV *self = (HV*)SvRV((SV*)data);
+_watch_generic(DBusWatch *watch, void *data, char *key, dbus_bool_t server) {
+ SV *selfref;
+ HV *self;
SV **call;
SV *h_sv1;
SV *h_sv2;
dSP;
-printf("In watxh %x %x %s\n", data, self, key);
+
+ PD_DEBUG("Watch generic callback %x %x %s %d\n", watch, data, key, server);
+
+ if (server) {
+ selfref = (SV*)dbus_server_get_data((DBusServer*)data, server_data_slot);
+ } else {
+ selfref = (SV*)dbus_connection_get_data((DBusConnection*)data, connection_data_slot);
+ }
+ self = (HV*)SvRV(selfref);
+
+ PD_DEBUG("Got owner %x\n", self);
call = hv_fetch(self, key, strlen(key), 0);
if (!call) {
-printf("Could not find call %s\n", key);
+ warn("Could not find watch callback %s for fd %d\n",
+ key, dbus_watch_get_fd(watch));
return FALSE;
}
@@ -25,7 +56,7 @@ printf("Could not find call %s\n", key);
SAVETMPS;
PUSHMARK(SP);
- XPUSHs((SV*)data);
+ XPUSHs(selfref);
h_sv2 = sv_newmortal();
sv_setref_pv(h_sv2, "DBus::C::Watch", (void*)watch);
XPUSHs(h_sv2);
@@ -39,22 +70,102 @@ printf("Could not find call %s\n", key);
dbus_bool_t
_watch_server_add(DBusWatch *watch, void *data) {
- return _watch_generic(watch, data, "add_watch");
+ return _watch_generic(watch, data, "add_watch", 1);
}
void
_watch_server_remove(DBusWatch *watch, void *data) {
- _watch_generic(watch, data, "remove_watch");
+ _watch_generic(watch, data, "remove_watch", 1);
}
void
_watch_server_toggled(DBusWatch *watch, void *data) {
- _watch_generic(watch, data, "toggled_watch");
+ _watch_generic(watch, data, "toggled_watch", 1);
+}
+
+dbus_bool_t
+_watch_connection_add(DBusWatch *watch, void *data) {
+ return _watch_generic(watch, data, "add_watch", 0);
+}
+void
+_watch_connection_remove(DBusWatch *watch, void *data) {
+ _watch_generic(watch, data, "remove_watch", 0);
+}
+void
+_watch_connection_toggled(DBusWatch *watch, void *data) {
+ _watch_generic(watch, data, "toggled_watch", 0);
+}
+
+
+dbus_bool_t
+_timeout_generic(DBusTimeout *timeout, void *data, char *key, dbus_bool_t server) {
+ SV *selfref;
+ HV *self;
+ SV **call;
+ SV *h_sv1;
+ SV *h_sv2;
+ dSP;
+
+ if (server) {
+ selfref = (SV*)dbus_server_get_data((DBusServer*)data, server_data_slot);
+ } else {
+ selfref = (SV*)dbus_connection_get_data((DBusConnection*)data, connection_data_slot);
+ }
+ self = (HV*)SvRV(selfref);
+
+ call = hv_fetch(self, key, strlen(key), 0);
+
+ if (!call) {
+ warn("Could not find timeout callback for %s\n", key);
+ return FALSE;
+ }
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP);
+ XPUSHs((SV*)selfref);
+ h_sv2 = sv_newmortal();
+ sv_setref_pv(h_sv2, "DBus::C::Timeout", (void*)timeout);
+ XPUSHs(h_sv2);
+ PUTBACK;
+
+ call_sv(*call, G_DISCARD);
+
+ FREETMPS;
+ LEAVE;
+}
+
+dbus_bool_t
+_timeout_server_add(DBusTimeout *timeout, void *data) {
+ return _timeout_generic(timeout, data, "add_timeout", 1);
+}
+void
+_timeout_server_remove(DBusTimeout *timeout, void *data) {
+ _timeout_generic(timeout, data, "remove_timeout", 1);
+}
+void
+_timeout_server_toggled(DBusTimeout *timeout, void *data) {
+ _timeout_generic(timeout, data, "toggled_timeout", 1);
+}
+
+dbus_bool_t
+_timeout_connection_add(DBusTimeout *timeout, void *data) {
+ return _timeout_generic(timeout, data, "add_timeout", 0);
+}
+void
+_timeout_connection_remove(DBusTimeout *timeout, void *data) {
+ _timeout_generic(timeout, data, "remove_timeout", 0);
+}
+void
+_timeout_connection_toggled(DBusTimeout *timeout, void *data) {
+ _timeout_generic(timeout, data, "toggled_timeout", 0);
}
void
_connection_callback (DBusServer *server,
DBusConnection *new_connection,
void *data) {
- HV *self = (HV *)SvRV((SV*)data);
+ SV *selfref = (SV*)dbus_server_get_data((DBusServer*)data, server_data_slot);
+ HV *self = (HV*)SvRV(selfref);
SV **call;
SV *proto;
SV *name;
@@ -65,9 +176,11 @@ _connection_callback (DBusServer *server,
call = hv_fetch(self, "_callback", strlen("_callback"), 0);
if (!call) {
+ warn("Could not find new connection callback\n");
return;
}
+ /* The DESTROY method will de-ref it no matter what */
dbus_connection_ref(new_connection);
value = sv_newmortal();
@@ -77,7 +190,7 @@ _connection_callback (DBusServer *server,
SAVETMPS;
PUSHMARK(SP);
- XPUSHs((SV*)data);
+ XPUSHs(selfref);
XPUSHs(value);
PUTBACK;
@@ -87,6 +200,47 @@ _connection_callback (DBusServer *server,
LEAVE;
}
+
+void
+_path_unregister_callback(DBusConnection *con,
+ void *data) {
+ SvREFCNT_dec(data);
+}
+
+DBusHandlerResult
+_path_message_callback(DBusConnection *con,
+ DBusMessage *msg,
+ void *data) {
+ SV *self = (SV*)dbus_connection_get_data(con, connection_data_slot);
+ SV *value;
+ dSP;
+
+ value = sv_newmortal();
+ sv_setref_pv(value, "DBus::C::Message", (void*)msg);
+
+ ENTER;
+ SAVETMPS;
+
+ PUSHMARK(SP);
+ XPUSHs(self);
+ XPUSHs(value);
+ PUTBACK;
+
+ call_sv((SV*)data, G_DISCARD);
+
+ FREETMPS;
+ LEAVE;
+}
+
+DBusObjectPathVTable _path_callback_vtable = {
+ _path_unregister_callback,
+ _path_message_callback,
+ NULL,
+ NULL,
+ NULL,
+ NULL
+};
+
void
_populate_constant(HV *href, char *name, int val)
{
@@ -130,6 +284,9 @@ BOOT:
REGISTER_CONSTANT(DBUS_WATCH_WRITABLE, WRITABLE);
REGISTER_CONSTANT(DBUS_WATCH_ERROR, ERROR);
REGISTER_CONSTANT(DBUS_WATCH_HANGUP, HANGUP);
+
+ dbus_connection_allocate_data_slot(&connection_data_slot);
+ dbus_server_allocate_data_slot(&server_data_slot);
}
@@ -137,14 +294,14 @@ MODULE = DBus::Connection PACKAGE = DBus::Connection
PROTOTYPES: ENABLE
-void
+DBusConnection *
_open(address)
char *address;
PREINIT:
DBusError error;
DBusConnection *con;
SV *h_sv;
- PPCODE:
+ CODE:
dbus_error_init(&error);
con = dbus_connection_open(address, &error);
if (!con) {
@@ -152,14 +309,21 @@ _open(address)
//dbus_error_free(&error);
croak(error.message);
}
- h_sv = sv_newmortal();
- sv_setref_pv(h_sv, "DBus::C::Connection", (void*)con);
-
- PUSHs(h_sv);
+ RETVAL = con;
+ OUTPUT:
+ RETVAL
MODULE = DBus::C::Connection PACKAGE = DBus::C::Connection
void
+_set_owner(con, owner)
+ DBusConnection *con;
+ SV *owner;
+ CODE:
+ SvREFCNT_inc(owner);
+ dbus_connection_set_data(con, connection_data_slot, owner, _object_release);
+
+void
dbus_connection_disconnect(con)
DBusConnection *con;
@@ -167,6 +331,10 @@ int
dbus_connection_get_is_connected(con)
DBusConnection *con;
+int
+dbus_connection_get_is_authenticated(con)
+ DBusConnection *con;
+
void
dbus_connection_flush(con)
DBusConnection *con;
@@ -185,37 +353,108 @@ _send(con, msg)
OUTPUT:
RETVAL
+DBusMessage *
+_send_with_reply_and_block(con, msg, timeout)
+ DBusConnection *con;
+ DBusMessage *msg;
+ int timeout;
+ PREINIT:
+ DBusMessage *reply;
+ DBusError error;
+ SV *h_sv;
+ CODE:
+ dbus_error_init(&error);
+ if (!(reply = dbus_connection_send_with_reply_and_block(con, msg, timeout, &error))) {
+ croak(error.message);
+ }
+ RETVAL = reply;
+ OUTPUT:
+ RETVAL
+
+DBusMessage *
+dbus_connection_borrow_message(con)
+ DBusConnection *con;
+
+void
+dbus_connection_return_message(con, msg)
+ DBusConnection *con;
+ DBusMessage *msg;
+
+void
+dbus_connection_steal_borrowed_message(con, msg)
+ DBusConnection *con;
+ DBusMessage *msg;
+
+DBusMessage *
+dbus_connection_pop_message(con)
+ DBusConnection *con;
+
+void
+_dispatch(con)
+ DBusConnection *con;
+ CODE:
+ while(dbus_connection_dispatch(con) == DBUS_DISPATCH_DATA_REMAINS);
+
void
-_set_watch_callbacks(con, self)
+_set_watch_callbacks(con)
DBusConnection *con;
- SV *self;
- PPCODE:
- SvREFCNT_inc(self);
+ CODE:
if (!dbus_connection_set_watch_functions(con,
- _watch_server_add,
- _watch_server_remove,
- _watch_server_toggled,
- self, NULL)) {
+ _watch_connection_add,
+ _watch_connection_remove,
+ _watch_connection_toggled,
+ con, NULL)) {
croak("not enough memory to set watch functions on connection");
}
void
-dbus_connection_unref(con)
+_set_timeout_callbacks(con)
+ DBusConnection *con;
+ CODE:
+ if (!dbus_connection_set_timeout_functions(con,
+ _timeout_connection_add,
+ _timeout_connection_remove,
+ _timeout_connection_toggled,
+ con, NULL)) {
+ croak("not enough memory to set timeout functions on connection");
+ }
+
+void
+_register_message_handler(con, path, code)
+ DBusConnection *con;
+ char *path;
+ SV *code;
+ PREINIT:
+ char *paths[2];
+ CODE:
+ paths[0] = path;
+ paths[1] = NULL;
+
+ SvREFCNT_inc(code);
+ if (!(dbus_connection_register_object_path(con, paths, &_path_callback_vtable, code))) {
+ croak("not enough memory to register object path");
+ }
+
+void
+DESTROY(con)
DBusConnection *con;
+ CODE:
+ PD_DEBUG("Destroying connection %x\n", con);
+ dbus_connection_unref(con);
MODULE = DBus::Server PACKAGE = DBus::Server
PROTOTYPES: ENABLE
-void
+DBusServer *
_open(address)
char *address;
PREINIT:
DBusError error;
DBusServer *server;
SV *h_sv;
- PPCODE:
+ CODE:
dbus_error_init(&error);
server = dbus_server_listen(address, &error);
if (!server) {
@@ -223,18 +462,25 @@ _open(address)
//dbus_error_free(&error);
croak(error.message);
}
- h_sv = sv_newmortal();
- sv_setref_pv(h_sv, "DBus::C::Server", (void*)server);
-
if (!dbus_server_set_auth_mechanisms(server, NULL)) {
croak("not enough memory to server auth mechanisms");
}
+ RETVAL = server;
+ OUTPUT:
+ RETVAL
- PUSHs(h_sv);
MODULE = DBus::C::Server PACKAGE = DBus::C::Server
void
+_set_owner(server, owner)
+ DBusServer *server;
+ SV *owner;
+ CODE:
+ SvREFCNT_inc(owner);
+ dbus_server_set_data(server, server_data_slot, owner, _object_release);
+
+void
dbus_server_disconnect(server)
DBusServer *server;
@@ -243,49 +489,59 @@ dbus_server_get_is_connected(server)
DBusServer *server;
void
-_set_watch_callbacks(server, self)
+_set_watch_callbacks(server)
DBusServer *server;
- SV *self;
- PPCODE:
- SvREFCNT_inc(self);
- printf("Setting2 %x %x %x\n", server, self, SvRV(self));
+ CODE:
if (!dbus_server_set_watch_functions(server,
_watch_server_add,
_watch_server_remove,
_watch_server_toggled,
- self, NULL)) {
+ server, NULL)) {
croak("not enough memory to set watch functions on server");
}
void
-_set_connection_callback(server, self)
+_set_timeout_callbacks(server)
DBusServer *server;
- SV *self;
- PPCODE:
- SvREFCNT_inc(self);
- printf("Setting %x %x %x\n", server, self, SvRV(self));
+ CODE:
+ if (!dbus_server_set_timeout_functions(server,
+ _timeout_server_add,
+ _timeout_server_remove,
+ _timeout_server_toggled,
+ server, NULL)) {
+ croak("not enough memory to set timeout functions on server");
+ }
+
+
+void
+_set_connection_callback(server)
+ DBusServer *server;
+ CODE:
dbus_server_set_new_connection_function(server,
_connection_callback,
- self, NULL);
+ server, NULL);
void
-dbus_server_unref(server)
+DESTROY(server)
DBusServer *server;
+ CODE:
+ PD_DEBUG("Destroying server %x\n", server);
+ dbus_server_unref(server);
MODULE = DBus::Bus PACKAGE = DBus::Bus
PROTOTYPES: ENABLE
-void
+DBusConnection *
_open(type)
DBusBusType type;
PREINIT:
DBusError error;
DBusConnection *con;
SV *h_sv;
- PPCODE:
+ CODE:
dbus_error_init(&error);
con = dbus_bus_get(type, &error);
if (!con) {
@@ -293,69 +549,72 @@ _open(type)
//dbus_error_free(error);
croak(error.message);
}
- h_sv = sv_newmortal();
- sv_setref_pv(h_sv, "DBus::C::Connection", (void*)con);
-
- PUSHs(h_sv);
+ RETVAL = con;
+ OUTPUT:
+ RETVAL
MODULE = DBus::Message PACKAGE = DBus::Message
PROTOTYPES: ENABLE
-void
+DBusMessage *
_create(type)
IV type;
PREINIT:
DBusMessage *msg;
SV *h_sv;
- PPCODE:
+ CODE:
msg = dbus_message_new(type);
if (!msg) {
croak("No memory to allocate message");
}
- h_sv = sv_newmortal();
- sv_setref_pv(h_sv, "DBus::C::Message", (void*)msg);
-
- PUSHs(h_sv);
+ RETVAL = msg;
+ OUTPUT:
+ RETVAL
void
set_no_reply(msg, status)
DBusMessage *msg;
dbus_bool_t status;
- PPCODE:
+ CODE:
dbus_message_set_no_reply(msg, status);
void
set_auto_activation(msg, status)
DBusMessage *msg;
dbus_bool_t status;
- PPCODE:
+ CODE:
dbus_message_set_auto_activation(msg, status);
-void
-_destroy(msg)
- DBusMessage *msg;
- PPCODE:
- dbus_message_unref(msg);
-
-void
+DBusMessageIter *
_iterator(msg)
DBusMessage *msg;
PREINIT:
DBusMessageIter *iter;
SV *h_sv;
- PPCODE:
+ CODE:
iter = dbus_new(DBusMessageIter, 1);
dbus_message_iter_init(msg, iter);
- h_sv = sv_newmortal();
- sv_setref_pv(h_sv, "DBus::C::Iterator", iter);
- PUSHs(h_sv);
+ RETVAL = iter;
+ OUTPUT:
+ RETVAL
+
+
+MODULE = DBus::C::Message PACKAGE = DBus::C::Message
+
+void
+DESTROY(msg)
+ DBusMessage *msg;
+ CODE:
+ PD_DEBUG("Destroying message %x\n", msg);
+ dbus_message_unref(msg);
+
MODULE = DBus::Message::Signal PACKAGE = DBus::Message::Signal
PROTOTYPES: ENABLE
-void
+DBusMessage *
_create(path, interface, name)
char *path;
char *interface;
@@ -363,21 +622,20 @@ _create(path, interface, name)
PREINIT:
DBusMessage *msg;
SV *h_sv;
- PPCODE:
+ CODE:
msg = dbus_message_new_signal(path, interface, name);
if (!msg) {
croak("No memory to allocate message");
}
- h_sv = sv_newmortal();
- sv_setref_pv(h_sv, "DBus::C::Message", (void*)msg);
-
- PUSHs(h_sv);
+ RETVAL = msg;
+ OUTPUT:
+ RETVAL
MODULE = DBus::Message::MethodCall PACKAGE = DBus::Message::MethodCall
PROTOTYPES: ENABLE
-void
+DBusMessage *
_create(service, path, interface, method)
char *service;
char *path;
@@ -386,41 +644,39 @@ _create(service, path, interface, method)
PREINIT:
DBusMessage *msg;
SV *h_sv;
- PPCODE:
+ CODE:
msg = dbus_message_new_method_call(service, path, interface, method);
if (!msg) {
croak("No memory to allocate message");
}
- h_sv = sv_newmortal();
- sv_setref_pv(h_sv, "DBus::C::Message", (void*)msg);
-
- PUSHs(h_sv);
+ RETVAL = msg;
+ OUTPUT:
+ RETVAL
MODULE = DBus::Message::MethodReturn PACKAGE = DBus::Message::MethodReturn
PROTOTYPES: ENABLE
-void
+DBusMessage *
_create(call)
DBusMessage *call;
PREINIT:
DBusMessage *msg;
SV *h_sv;
- PPCODE:
+ CODE:
msg = dbus_message_new_method_return(call);
if (!msg) {
croak("No memory to allocate message");
}
- h_sv = sv_newmortal();
- sv_setref_pv(h_sv, "DBus::C::Message", (void*)msg);
-
- PUSHs(h_sv);
+ RETVAL = msg;
+ OUTPUT:
+ RETVAL
MODULE = DBus::Message::Error PACKAGE = DBus::Message::Error
PROTOTYPES: ENABLE
-void
+DBusMessage *
_create(replyto, name, message)
DBusMessage *replyto;
char *name;
@@ -428,15 +684,14 @@ _create(replyto, name, message)
PREINIT:
DBusMessage *msg;
SV *h_sv;
- PPCODE:
+ CODE:
msg = dbus_message_new_error(replyto, name, message);
if (!msg) {
croak("No memory to allocate message");
}
- h_sv = sv_newmortal();
- sv_setref_pv(h_sv, "DBus::C::Message", (void*)msg);
-
- PUSHs(h_sv);
+ RETVAL = msg;
+ OUTPUT:
+ RETVAL
MODULE = DBus::C::Watch PACKAGE = DBus::C::Watch
@@ -469,10 +724,67 @@ void
handle(watch, flags)
DBusWatch *watch;
unsigned int flags;
- PPCODE:
- printf("Handling event %d\n", flags);
+ CODE:
+ PD_DEBUG("Handling event %d on fd %d (%x)\n", flags, dbus_watch_get_fd(watch), watch);
dbus_watch_handle(watch, flags);
+
+void *
+get_data(watch)
+ DBusWatch *watch;
+ CODE:
+ RETVAL = dbus_watch_get_data(watch);
+ OUTPUT:
+ RETVAL
+
+void
+set_data(watch, data)
+ DBusWatch *watch;
+ void *data;
+ CODE:
+ dbus_watch_set_data(watch, data, NULL);
+
+
+MODULE = DBus::C::Timeout PACKAGE = DBus::C::Timeout
+
+int
+get_interval(timeout)
+ DBusTimeout *timeout;
+ CODE:
+ RETVAL = dbus_timeout_get_interval(timeout);
+ OUTPUT:
+ RETVAL
+
+dbus_bool_t
+is_enabled(timeout)
+ DBusTimeout *timeout;
+ CODE:
+ RETVAL = dbus_timeout_get_enabled(timeout);
+ OUTPUT:
+ RETVAL
+
+void
+handle(timeout)
+ DBusTimeout *timeout;
+ CODE:
+ PD_DEBUG("Handling timeout event %x\n", timeout);
+ dbus_timeout_handle(timeout);
+
+void *
+get_data(timeout)
+ DBusTimeout *timeout;
+ CODE:
+ RETVAL = dbus_timeout_get_data(timeout);
+ OUTPUT:
+ RETVAL
+
+void
+set_data(timeout, data)
+ DBusTimeout *timeout;
+ void *data;
+ CODE:
+ dbus_timeout_set_data(timeout, data, NULL);
+
MODULE = DBus::Iterator PACKAGE = DBus::Iterator
int
@@ -532,7 +844,7 @@ get_uint32(iter)
RETVAL
dbus_int64_t
-get_int64(iter)
+_get_int64(iter)
DBusMessageIter *iter;
CODE:
RETVAL = dbus_message_iter_get_int64(iter);
@@ -540,7 +852,7 @@ get_int64(iter)
RETVAL
dbus_uint64_t
-get_uint64(iter)
+_get_uint64(iter)
DBusMessageIter *iter;
CODE:
RETVAL = dbus_message_iter_get_uint64(iter);
@@ -567,67 +879,70 @@ get_string(iter)
void
append_nil(iter)
DBusMessageIter *iter;
- PPCODE:
+ CODE:
dbus_message_iter_append_nil(iter);
void
append_boolean(iter, val)
DBusMessageIter *iter;
dbus_bool_t val;
- PPCODE:
+ CODE:
dbus_message_iter_append_boolean(iter, val);
void
append_byte(iter, val)
DBusMessageIter *iter;
unsigned char val;
- PPCODE:
+ CODE:
dbus_message_iter_append_byte(iter, val);
void
append_int32(iter, val)
DBusMessageIter *iter;
dbus_int32_t val;
- PPCODE:
+ CODE:
dbus_message_iter_append_int32(iter, val);
void
append_uint32(iter, val)
DBusMessageIter *iter;
dbus_uint32_t val;
- PPCODE:
+ CODE:
dbus_message_iter_append_uint32(iter, val);
void
-append_int64(iter, val)
+_append_int64(iter, val)
DBusMessageIter *iter;
dbus_int64_t val;
- PPCODE:
+ CODE:
dbus_message_iter_append_int64(iter, val);
void
-append_uint64(iter, val)
+_append_uint64(iter, val)
DBusMessageIter *iter;
dbus_uint64_t val;
- PPCODE:
+ CODE:
dbus_message_iter_append_uint64(iter, val);
void
append_double(iter, val)
DBusMessageIter *iter;
double val;
- PPCODE:
+ CODE:
dbus_message_iter_append_double(iter, val);
void
append_string(iter, val)
DBusMessageIter *iter;
char *val;
- PPCODE:
+ CODE:
dbus_message_iter_append_string(iter, val);
void
-dbus_free(iter)
+DESTROY(iter)
DBusMessageIter *iter;
+ CODE:
+ PD_DEBUG("Destroying iterator %x\n", iter);
+ dbus_free(iter);
MODULE = DBus PACKAGE = DBus
diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP
new file mode 100644
index 0000000..5bb2c71
--- /dev/null
+++ b/MANIFEST.SKIP
@@ -0,0 +1,10 @@
+pm_to_blib
+DBus-
+blib
+.*\.bak
+CVS
+.cvsignore
+.*~
+.#.*
+#.*
+^Makefile$
diff --git a/Makefile.PL b/Makefile.PL
index 5f6c2b5..c80de1e 100644
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -3,18 +3,36 @@ use ExtUtils::MakeMaker;
# See lib/ExtUtils/MakeMaker.pm for details of how to influence
# the contents of the Makefile that is written.
+$DBUS_HOME="/usr";
+#$DBUS_HOME="/usr/local";
+#$DBUS_HOME="/usr/local/dbus-0.21";
+#$DBUS_HOME="/opt/dbus-0.21";
+
+$DEBUG="";
+#$DEBUG="-DPD_DO_DEBUG";
+
+foreach (@ARGV) {
+ if (/^DBUS_HOME=(.*)$/) {
+ $DBUS_HOME = $1;
+ } elsif (/^DEBUG=0$/) {
+ $DEBUG = "";
+ } elsif (/^DEBUG=1$/) {
+ $DEBUG = "-PPD_DO_DEBUG";
+ }
+}
+
WriteMakefile(
- 'NAME' => 'DBus',
- 'VERSION_FROM' => 'lib/DBus.pm', # finds $VERSION
- 'PREREQ_PM' => {'Test::More' => 0}, # e.g., Module::Name => 1.1
- ($] >= 5.005 ? ## Add these new keywords supported since 5.005
- (ABSTRACT_FROM => 'lib/DBus.pm', # retrieve abstract from module
- AUTHOR => 'Daniel Berrange <dan at berrange.com>') : ()),
- 'LIBS' => ['-L/home/dan/usr/dbus-cvs/lib -ldbus-1'], # e.g., '-lm'
- 'DEFINE' => '-DDBUS_API_SUBJECT_TO_CHANGE', # e.g., '-DHAVE_SOMETHING'
- 'INC' => '-I. -I/home/dan/usr/dbus-cvs/include/dbus-1.0 -I/home/dan/usr/dbus-cvs/lib/dbus-1.0/include', # e.g., '-I. -I/usr/include/other'
- # Un-comment this if you add C files to link with later:
- # 'OBJECT' => '$(O_FILES)', # link all the C files too
+ 'NAME' => 'DBus',
+ 'VERSION_FROM' => 'lib/DBus.pm',
+ 'PREREQ_PM' => {
+ 'Test::More' => 0,
+ 'Time::HiRes' => 0,
+ },
+ 'ABSTRACT_FROM' => 'lib/DBus.pm',
+ 'AUTHOR' => 'Daniel Berrange <dan at berrange.com>',
+ 'LIBS' => ['-L$DBUS_HOME/lib -ldbus-1'],
+ 'DEFINE' => '-DDBUS_API_SUBJECT_TO_CHANGE $DEBUG',
+ 'INC' => '-I$DBUS_HOME/include/dbus-1.0 -I$DBUS_HOME/lib/dbus-1.0/include',
);
package MY;
diff --git a/README b/README
index 1bc7ea7..d56a7be 100644
--- a/README
+++ b/README
@@ -1,38 +1,118 @@
-DBus version 0.01
+DBus version 0.0.1
=================
-The README is used to introduce the module and provide instructions on
-how to install the module, any machine dependencies it may have (for
-example C compilers and installed libraries) and any other information
-that should be provided before the module is installed.
+DBus provides a Perl XS API to the dbus inter-application
+messaging system. The Perl API covers the core base level
+of the dbus APIs, not concerning itself yet with the GLib
+or QT wrappers. For more information on dbus visit the
+project website at:
-A README file is required for CPAN modules since CPAN extracts the
-README file from a module distribution so that people browsing the
-archive can use it get an idea of the modules uses. It is usually a
-good idea to provide version information here so that people can
-decide whether fixes for the module are worth downloading.
+ http://www.freedesktop.org/software/dbus/
INSTALLATION
+------------
To install this module type the following:
perl Makefile.PL
make
make test
+ sudo make install
+
+If your dbus installation is not in the /usr prefix,
+the the argument DBUS_HOME must be used to specify
+the instllation prefix when generating the Makefile.
+For example, if dbus were initially configured and
+built with 'configure --prefix=$HOME/dbus-0.21' then
+the installation procedure for this Perl module would
+be
+
+ perl Makefile.PL DBUS_HOME=$HOME/dbus-0.21
+ make
+ make test
make install
+The XS layer has the capability to output information
+about its operation on STDERR during normal operation.
+Due to its performance hit, this capability must be
+enabled when initially compiling the DBus module by
+specifying the 'DEBUG=1' parameter:
+
+ perl Makefile.PL DEBUG=1
+
+In addition, when running a program the environment
+variable PD_DEBUG must be set (to any value).
+
DEPENDENCIES
+------------
-This module requires these other modules and libraries:
+In keeping with the C API, the Perl DBus implementation
+has minimal external dependancies:
Test::More
+ Time::HiRes
-COPYRIGHT AND LICENCE
+Both of these modules are present as standard in versions
+of Perl >= 5.8.0, while for earlier versions they may
+be obtained from CPAN (http://search.cpan.org/).
+
+EXAMPLES
+--------
+
+There are two examples programs present in the top
+level 'examples' directory. One acts as a server,
+the other acts as a client. They communicate using
+the UNIX socket /tmp/perl-dbus-test. Once the DBus
+modules have been installed, they maybe run as
+follows:
+
+ perl examples/sever.pl
+
+ perl examples/client.pl
+
+Control+C will be required to make them exit, since
+once connected, they simply sleep/spin around in their
+main event loop chatting to each other.
-Put the correct copyright and licence information here.
+CONTRIBUTIONS
+-------------
+
+Contributions both simple bug fixes & new features are
+always welcome. Please supply patches in context, or
+unified diff format. A simple method to generate such a
+patch is as follows:
+
+ * Clean out generated files from your working
+ directory:
+
+ make distclean
+
+ * Rename your working directory to have '-new'
+ extension:
+
+ mv DBus-0.0.1 DBus-0.0.1-new
+
+ * Extract a pristine copy of the source:
+
+ gunzip -c DBus-0.0.1.tar.gz | tar xf -
+ mv DBus-0.0.1 DBus-0.0.1-orig
+
+ * Generate the patch:
+
+ diff -ruN DBus-0.0.1-orig DBus-0.0.1-new \
+ > DBus-0.0.1-[something].patch
+ gzip DBus-0.0.1-[something].patch
+
+
+Send the resulting to .patch.gz file directly to
+Daniel Berrange <dan at berrange dot com>
+
+COPYRIGHT AND LICENCE
+---------------------
Copyright (C) 2004 Daniel Berrange
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
+This library is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+-- End
diff --git a/lib/DBus.pm b/lib/DBus.pm
index afecea7..0a33f1b 100644
--- a/lib/DBus.pm
+++ b/lib/DBus.pm
@@ -7,7 +7,7 @@ use Carp;
use AutoLoader;
-our $VERSION = '0.01';
+our $VERSION = '0.0.1';
require XSLoader;
XSLoader::load('DBus', $VERSION);
@@ -34,7 +34,11 @@ DBus provides a Perl API for the DBus message system.
There is no need to access this module directly. It is
used by other DBus::* module to trigger the autoloading
of the XS module containing the interface to the DBus
-API
+API. The DBus Perl interface was written against version
+0.21 of dbus, and has had rudimentary testing against the
+development branch that will become 0.22. The two modules
+of main interest will be L<DBus::Connection> and
+L<DBus::Server>.
=head1 SEE ALSO
diff --git a/lib/DBus/Callback.pm b/lib/DBus/Callback.pm
new file mode 100644
index 0000000..d49a4e4
--- /dev/null
+++ b/lib/DBus/Callback.pm
@@ -0,0 +1,42 @@
+package DBus::Callback;
+
+use 5.006;
+use strict;
+use warnings;
+use Carp qw(confess);
+use DBus::Watch;
+
+our $VERSION = '0.0.1';
+
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my %params = @_;
+ my $self = {};
+
+ $self->{object} = $params{object} ? $params{object} : undef;
+ $self->{method} = $params{method} ? $params{method} : confess "method parameter is required";
+ $self->{args} = $params{args} ? $params{args} : [];
+
+ bless $self, $class;
+
+ return $self;
+}
+
+
+sub invoke {
+ my $self = shift;
+
+ if ($self->{object}) {
+ my $obj = $self->{object};
+ my $method = $self->{method};
+
+ $obj->$method(@{$self->{args}});
+ } else {
+ my $method = $self->{method};
+
+ &$method(@{$self->{args}});
+ }
+}
+
+1;
diff --git a/lib/DBus/Connection.pm b/lib/DBus/Connection.pm
index 42f750d..228d57c 100644
--- a/lib/DBus/Connection.pm
+++ b/lib/DBus/Connection.pm
@@ -14,10 +14,38 @@ Creating a connection to a server and sending a message
$con->send($message);
+Registering message handlers
+
+ sub handle_something {
+ my $con = shift;
+ my $msg = shift;
+
+ ... do something with the message...
+ }
+
+ $con->register_message_handler(
+ "/some/object/path",
+ \&handle_something);
+
+Hooking up to an event loop:
+
+ my $reactor = DBus::Reactor->new();
+
+ $reactor->manage($con);
+
+ $reactor->run();
+
=head1 DESCRIPTION
An outgoing connection to a server, or an incoming connection
-from a client.
+from a client. The methods defined on this module have a close
+correspondance to the dbus_connection_XXX methods in the C API,
+so for further details on their behaviour, the C API documentation
+may be of use.
+
+=head1 METHODS
+
+=over 4
=cut
@@ -29,9 +57,19 @@ use warnings;
use Carp;
use DBus;
+use DBus::Message::MethodReturn;
our $VERSION = '0.0.1';
+=pod
+
+=item my $con = DBus::Connection->new(address => "unix:path=/path/to/socket");
+
+Creates a new connection to the remove server specified by
+the parameter C<address>.
+
+=cut
+
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
@@ -43,16 +81,54 @@ sub new {
bless $self, $class;
+ $self->{connection}->_set_owner($self);
+
return $self;
}
+=pod
+
+=item $status = $con->is_connected();
+
+Returns zero if the connection has been disconnected,
+otherwise a positive value is returned.
+
+=cut
+
sub is_connected {
my $self = shift;
return $self->{connection}->dbus_connection_get_is_connected();
}
+=pod
+
+=item $status = $con->is_authenticated();
+
+Returns zero if the connection has not yet successfully
+completed authentication, otherwise a positive value is
+returned.
+
+=cut
+
+sub is_authenticated {
+ my $self = shift;
+
+ return $self->{connection}->dbus_connection_get_is_authenticated();
+}
+
+
+=pod
+
+=item $con->disconnect()
+
+Closes this connection to the remote host. This method
+is called automatically during garbage collection (ie
+in the DESTROY method) if the programmer forgets to
+explicitly disconnect.
+
+=cut
sub disconnect {
my $self = shift;
@@ -60,6 +136,15 @@ sub disconnect {
$self->{connection}->dbus_connection_disconnect();
}
+=pod
+
+=item $con->flush()
+
+Blocks execution until all data in the outgoing data
+stream has been sent. This method will not re-enter
+the application event loop.
+
+=cut
sub flush {
my $self = shift;
@@ -68,6 +153,21 @@ sub flush {
}
+=pod
+
+=item $con->send($message)
+
+Queues a message up for sending to the remote host.
+The data will be sent asynchronously as the applications
+event loop determines there is space in the outgoing
+socket send buffer. To force immediate sending of the
+data, follow this method will a call to C<flush>. This
+method will return the serial number of the message,
+which can be used to identify a subsequent reply (if
+any).
+
+=cut
+
sub send {
my $self = shift;
my $msg = shift;
@@ -75,6 +175,132 @@ sub send {
return $self->{connection}->_send($msg->{message});
}
+=pod
+
+=item my $reply = $con->send_with_reply_and_block($msg);
+
+Queues a message up for sending to the remote host
+and blocks until it has been sent, and a corresponding
+reply received. The return value of this method will
+be a C<DBus::Message::MethodReturn> or C<DBus::Message::Error>
+object.
+
+=cut
+
+sub send_with_reply_and_block {
+ my $self = shift;
+ my $msg = shift;
+
+ my $reply = $self->{connection}->_send_with_reply_and_block($msg->{message});
+ return DBus::Message::MethodReturn->new(message => $reply);
+}
+
+
+=pod
+
+=item $con->dispatch;
+
+Dispatches any pending messages in the incoming queue
+to their message handlers. This method is typically
+called on each iteration of the main application event
+loop where data has been read from the incoming socket.
+
+=cut
+
+sub dispatch {
+ my $self = shift;
+
+ $self->{connection}->_dispatch();
+}
+
+
+=pod
+
+=item $message = $con->borrow_message
+
+Temporarily removes the first message from the incoming
+message queue. No other thread may access the message
+while it is 'borrowed', so it should be replaced in the
+queue with the C<return_message> method, or removed
+permanently with th C<steal_message> method as soon as
+is practical.
+
+=cut
+
+sub borrow_message {
+ my $self = shift;
+
+ my $msg = $self->{connection}->dbus_connection_borrow_message();
+ return DBus::Message->new(message => $msg);
+}
+
+=pod
+
+=item $con->return_message($msg)
+
+Replaces a previously borrowed message in the incoming
+message queue for subsequent dispatch to registered
+message handlers.
+
+=cut
+
+sub return_message {
+ my $self = shift;
+ my $msg = shift;
+
+ $self->{connection}->dbus_connection_return_message($msg->{message});
+}
+
+
+=pod
+
+=item $con->steal_message($msg)
+
+Permanently remove a borrowed message from the incoming
+message queue. No registered message handlers will now
+be run for this message.
+
+=cut
+
+sub steal_message {
+ my $self = shift;
+ my $msg = shift;
+
+ $self->{connection}->dbus_connection_steal_borrowed_message($msg->{message});
+}
+
+=pod
+
+=item $msg = $con->pop_message();
+
+Permanently removes the first message on the incoming
+message queue, without running any registered message
+handlers. If you have hooked the connection up to an
+event loop (C<DBus::Reactor> for example), you probably
+don't want to be calling this method.
+
+=cut
+
+sub pop_message {
+ my $self = shift;
+
+ my $msg = $self->{connection}->dbus_connection_pop_message();
+ return DBus::Message->new(message => $msg);
+}
+
+=pod
+
+=item $con->set_watch_callbacks(\&add_watch, \&remove_watch, \&toggle_watch);
+
+Register a set of callbacks for adding, removing & updating
+watches in the application's event loop. Each parameter
+should be a code reference, which on each invocation, will be
+supplied with two parameters, the connection object and the
+watch object. If you are using a C<DBus::Reactor> object
+as the application event loop, then the 'manage' method on
+that object will call this on your behalf.
+
+=cut
sub set_watch_callbacks {
my $self = shift;
@@ -86,24 +312,140 @@ sub set_watch_callbacks {
$self->{remove_watch} = $remove;
$self->{toggled_watch} = $toggled;
- $self->{connection}->_set_watch_callbacks($self);
+ $self->{connection}->_set_watch_callbacks();
}
+=pod
+
+=item $con->set_timeout_callbacks(\&add_timeout, \&remove_timeout, \&toggle_timeout);
+
+Register a set of callbacks for adding, removing & updating
+timeouts in the application's event loop. Each parameter
+should be a code reference, which on each invocation, will be
+supplied with two parameters, the connection object and the
+timeout object. If you are using a C<DBus::Reactor> object
+as the application event loop, then the 'manage' method on
+that object will call this on your behalf.
+
+=cut
-sub DESTROY {
+sub set_timeout_callbacks {
my $self = shift;
+ my $add = shift;
+ my $remove = shift;
+ my $toggled = shift;
+
+ $self->{add_timeout} = $add;
+ $self->{remove_timeout} = $remove;
+ $self->{toggled_timeout} = $toggled;
+
+ $self->{connection}->_set_timeout_callbacks();
+}
+
+=pod
+
+=item $con->register_message_handler($path, \&handler)
+
+Registers a handler for messages whose path matches
+that specified in the C<$path> parameter. The supplied
+code reference will be invoked with two parameters, the
+connection object on which the message was received,
+and the message to be processed (an instance of the
+C<DBus::Message> class).
+
+=cut
+
+sub register_message_handler {
+ my $self = shift;
+ my $path = shift;
+ my $code = shift;
+
+ my $callback = sub {
+ my $con = shift;
+ my $msg = shift;
+
+ &$code($con, DBus::Message->new(message => $msg));
+ };
- print "DESTROy $self $self->{connection}\n";
- if ($self->{connection}->dbus_connection_get_is_connected()) {
- $self->{connection}->dbus_connection_disconnect();
- }
- $self->{connection}->dbus_connection_unref();
+ $self->{connection}->_register_message_handler($path, $callback);
+}
+
+
+=pod
+
+=item $con->set_max_message_size($bytes)
+
+Sets the maximum allowable size of a single incoming
+message. Messages over this size will be rejected
+prior to exceeding this threshold. The message size
+is specified in bytes.
+
+=cut
+
+sub set_max_message_size {
+ my $self = shift;
+ my $size = shift;
+
+ $self->{connection}->dbus_connection_set_max_message_size($size);
+}
+
+=pod
+
+=item $bytes = $con->get_max_message_size();
+
+Retrieves the maximum allowable incoming
+message size. The returned size is measured
+in bytes.
+
+=cut
+
+sub get_max_message_size {
+ my $self = shift;
+
+ return $self->{connection}->dbus_connection_get_max_message_size;
+}
+
+=pod
+
+=item $con->set_max_received_size($bytes)
+
+Sets the maximum size of the incoming message queue.
+Once this threashold is exceeded, no more messages will
+be read from wire before one or more of the existing
+messages are dispatched to their registered handlers.
+The implication is that the message queue can exceed
+this threshold by at most the size of a single message.
+
+=cut
+
+sub set_max_received_size {
+ my $self = shift;
+ my $size = shift;
+
+ $self->{connection}->dbus_connection_set_max_received_size($size);
+}
+
+=pod
+
+=item $bytes $con->get_max_received_size()
+
+Retrieves the maximum incoming message queue size.
+The returned size is measured in bytes.
+
+=cut
+
+sub get_max_received_size {
+ my $self = shift;
+
+ return $self->{connection}->dbus_connection_get_max_received_size;
}
1;
=pod
+=back
+
=head1 SEE ALSO
L<DBus::Server>, L<DBus::Bus>, L<DBus::Message::Signal>, L<DBus::Message::MethodCall>, L<DBus::Message::MethodReturn>, L<DBus::Message::Error>
diff --git a/lib/DBus/Iterator.pm b/lib/DBus/Iterator.pm
index bdb75cf..eb17fd6 100644
--- a/lib/DBus/Iterator.pm
+++ b/lib/DBus/Iterator.pm
@@ -14,10 +14,34 @@ Creating a new message
$iterator->append_boolean(1);
$iterator->append_byte(123);
+
+Reading from a mesage
+
+ my $msg = ...get it from somewhere...
+ my $iter = $msg->iterator();
+
+ my $i = 0;
+ while ($iter->has_next()) {
+ $iter->next();
+ $i++;
+ if ($i == 1) {
+ my $val = $iter->get_boolean();
+ } elsif ($i == 2) {
+ my $val = $iter->get_byte();
+ }
+ }
+
=head1 DESCRIPTION
-Provides an iterator for reading and writing messages
-parameters.
+Provides an iterator for reading or writing message
+fields. This module provides a Perl API to access the
+dbus_message_iter_XXX methods in the C API. The array
+and dictionary types are not yet supported, and there
+are bugs in the Quad support (ie it always returns -1!).
+
+=head1 METHODS
+
+=over 4
=cut
@@ -27,24 +51,125 @@ package DBus::Iterator;
use 5.006;
use strict;
use warnings;
-use Carp;
+use Carp qw(confess);
use DBus;
our $VERSION = '0.0.1';
+our $have_quads = 0;
+
+BEGIN {
+ eval "pack 'Q', 1243456";
+ if ($@) {
+ $have_quads = 0;
+ } else {
+ $have_quads = 1;
+ }
+}
+
+=pod
+
+=item $res = $iter->has_next()
+
+Determines if there are any more fields in the message
+itertor to be read. Returns a positive value if there
+are more fields, zero otherwise.
+
+=item $success = $iter->next()
+
+Skips the iterator onto the next field in the message.
+Returns a positive value if the current field pointer
+was successfully advanced, zero otherwise.
+
+=item my $val = $iter->get_boolean()
+
+=item $iter->append_boolean($val);
+
+Read or write a boolean value from/to the
+message iterator
+
+=item my $val = $iter->get_byte()
+
+=item $iter->append_byte($val);
+
+Read or write a single byte value from/to the
+message iterator.
+
+=item my $val = $iter->get_string()
+
+=item $iter->append_string($val);
+
+Read or write a UTF-8 string value from/to the
+message iterator
+
+=item my $val = $iter->get_int32()
+
+=item $iter->append_int32($val);
-sub DESTROY {
+Read or write a signed 32 bit value from/to the
+message iterator
+
+=item my $val = $iter->get_uint32()
+
+=item $iter->append_uint32($val);
+
+Read or write an unsigned 32 bit value from/to the
+message iterator
+
+=item my $val = $iter->get_int64()
+
+=item $iter->append_int64($val);
+
+Read or write a signed 64 bit value from/to the
+message iterator
+
+=item my $val = $iter->get_uint64()
+
+=item $iter->append_uint64($val);
+
+Read or write an unsigned 64 bit value from/to the
+message iterator
+
+=item my $val = $iter->get_double()
+
+=item $iter->append_double($val);
+
+Read or write a double precision floating point value
+from/to the message iterator
+
+=cut
+
+sub get_int64 {
+ my $self = shift;
+ confess "Quads not supported on this platform\n" unless $have_quads;
+ return $self->_get_int64;
+}
+
+sub get_uint64 {
my $self = shift;
-
- $self->dbus_free();
+ confess "Quads not supported on this platform\n" unless $have_quads;
+ return $self->_get_uint64;
}
+sub append_int64 {
+ my $self = shift;
+ confess "Quads not supported on this platform\n" unless $have_quads;
+ $self->_append_int64(shift);
+}
+
+sub append_uint64 {
+ my $self = shift;
+ confess "Quads not supported on this platform\n" unless $have_quads;
+ $self->_append_uint64(shift);
+}
1;
=pod
+=back
+
=head1 SEE ALSO
L<DBus::Message>
diff --git a/lib/DBus/Message.pm b/lib/DBus/Message.pm
index b34cbff..f0ba673 100644
--- a/lib/DBus/Message.pm
+++ b/lib/DBus/Message.pm
@@ -25,6 +25,10 @@ one of the four sub-types L<DBus::Message::Signal>,
L<DBus::Message::MethodCall>, L<DBus::Message::MethodReturn>,
L<DBus::Message::Error> should be used.
+=head1 METHODS
+
+=over 4
+
=cut
package DBus::Message;
@@ -54,17 +58,22 @@ sub new {
}
+=pod
+
+=item my $iterator = $msg->iterator;
+
+Retrieves an iterator which can be used for reading or
+writing fields of the message. The returned object is
+an instance of the C<DBus::Iterator> class.
+
+=cut
+
sub iterator {
my $self = shift;
return DBus::Message::_iterator($self->{message});
}
-sub DESTROY {
- my $self = shift;
-
- DBus::Message::_destroy($self->{message});
-}
sub AUTOLOAD {
# This AUTOLOAD is used to 'autoload' constants from the constant()
@@ -91,6 +100,8 @@ sub AUTOLOAD {
=pod
+=back
+
=head1 SEE ALSO
L<DBus::Server>, L<DBus::Connection>, L<DBus::Message::Signal>, L<DBus::Message::MethodCall>, L<DBus::Message::MethodReturn>, L<DBus::Message::Error>
diff --git a/lib/DBus/Message/Error.pm b/lib/DBus/Message/Error.pm
index e997a7e..8a65ece 100644
--- a/lib/DBus/Message/Error.pm
+++ b/lib/DBus/Message/Error.pm
@@ -22,8 +22,8 @@ sub new {
my $msg = DBus::Message::Error::_create
(
$replyto->{message},
- $params{name} ? $params{name} : confess "name parameter is required",
- $params{message} ? $params{message} : confess "message parameter is required");
+ ($params{name} ? $params{name} : confess "name parameter is required"),
+ ($params{message} ? $params{message} : confess "message parameter is required"));
my $self = $class->SUPER::new(%params, message => $msg);
diff --git a/lib/DBus/Reactor.pm b/lib/DBus/Reactor.pm
index d0e685c..74e6c15 100644
--- a/lib/DBus/Reactor.pm
+++ b/lib/DBus/Reactor.pm
@@ -1,3 +1,98 @@
+=pod
+
+=head1 NAME
+
+DBus::Reactor - application event loop
+
+=head1 SYNOPSIS
+
+Create and run an event loop:
+
+ use DBus::Reactor;
+ my $reactor = DBus::Reactor->new();
+
+ $reactor->run();
+
+Manage some file handlers
+
+ $reactor->add_read($fd,
+ DBus::Callback->new(method => sub {
+ my $fd = shift;
+ ...read some data...
+ }, args => [$fd]);
+
+ $reactor->add_write($fd,
+ DBus::Callback->new(method => sub {
+ my $fd = shift;
+ ...write some data...
+ }, args => [$fd]);
+
+Temporarily (dis|en)able a handle
+
+ # Disable
+ $reactor->toggle_read($fd, 0);
+ # Enable
+ $reactor->toggle_read($fd, 1);
+
+Permanently remove a handle
+
+ $reactor->remove_read($fd);
+
+Manage a regular timeout every 100 milliseconds
+
+ my $timer = $reactor->add_timeout(100,
+ DBus::Callback->new(
+ method => sub {
+ ...process the alarm...
+ }));
+
+Temporarily (dis|en)able a timer
+
+ # Disable
+ $reactor->toggle_timeout($timer, 0);
+ # Enable
+ $reactor->toggle_timeout($timer, 1);
+
+Permanently remove a timer
+
+ $reactor->remove_timeout($timer);
+
+Add a post-dispatch hook
+
+ my $hook = $reactor->add_hook(DBus::Callback->new(
+ method => sub {
+ ... do some work...
+ }));
+
+Remove a hook
+
+ $reactor->remove_hook($hook);
+
+=head1 DESCRIPTION
+
+This class provides a general purpose event loop for
+the purposes of multiplexing I/O events and timeouts
+in a single process. The underlying implementation is
+done using the select system call. File handles can
+be registered for monitoring on read, write and exception
+(out-of-band data) events. Timers can be registered
+to expire with a periodic frequency. These are implemented
+using the timeout parameter of the select system call.
+Since this parameter merely represents an upper bound
+on the amount of time the select system call is allowed
+to sleep, the actual period of the timers may vary. Under
+normal load this variance is typically 10 milliseconds.
+Finally, hooks may be registered which will be invoked on
+each iteration of the event loop (ie after processing
+the file events, or timeouts indicated by the select
+system call returning).
+
+=head1 METHODS
+
+=over 4
+
+=cut
+
package DBus::Reactor;
use 5.006;
@@ -5,9 +100,20 @@ use strict;
use warnings;
use Carp;
use DBus::Watch;
+use DBus::Callback;
+use Time::HiRes qw(gettimeofday);
our $VERSION = '0.0.1';
+=pod
+
+=item my $reactor = DBus::Reactor->new();
+
+Creates a new event loop ready for monitoring file
+handles, or generating timeouts.
+
+=cut
+
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
@@ -19,53 +125,119 @@ sub new {
write => {},
exception => {}
};
+ $self->{timeouts} = [];
+ $self->{hooks} = [];
bless $self, $class;
return $self;
}
+=pod
+
+=item $reactor->manage($connection);
+
+=item $reactor->manage($server);
+
+Registeres a C<DBus::Connection> or C<DBus::Server> object
+for management by the event loop. This basically involves
+hooking up the watch & timeout callbacks to the event loop.
+For connections it will also register a hook to invoke the
+C<dispatch> method periodically.
+
+=cut
sub manage {
my $self = shift;
- my $connection = shift;
+ my $object = shift;
+
+ if ($object->can("set_watch_callbacks")) {
+ $object->set_watch_callbacks(sub {
+ my $object = shift;
+ my $watch = shift;
+
+ $self->_manage_watch_on($object, $watch);
+ }, sub {
+ my $object = shift;
+ my $watch = shift;
+
+ $self->_manage_watch_off($object, $watch);
+ }, sub {
+ my $object = shift;
+ my $watch = shift;
+
+ $self->_manage_watch_toggle($object, $watch);
+ });
+ }
- $connection->set_watch_callbacks(sub {
- my $connection = shift;
- my $watch = shift;
- print "On $watch " . $watch->get_fileno . " " . $watch->get_flags . "\n";
- $self->_manage_on($watch);
- }, sub {
- my $connection = shift;
- my $watch = shift;
- print "Off $watch " . $watch->get_fileno . " " . $watch->get_flags . "\n";
- $self->_manage_off($watch);
- }, sub {
- my $connection = shift;
- my $watch = shift;
- print "Toggle $watch " . $watch->get_fileno . " " . $watch->get_flags . " " . $watch->is_enabled() . "\n";
- $self->_manage_state($watch);
- });
+ if ($object->can("set_timeout_callbacks")) {
+ $object->set_timeout_callbacks(sub {
+ my $object = shift;
+ my $timeout = shift;
+
+ my $key = $self->add_timeout($timeout->get_interval,
+ DBus::Callback->new(object => $timeout,
+ method => "handle",
+ args => []),
+ $timeout->is_enabled);
+ $timeout->set_data($key);
+ }, sub {
+ my $object = shift;
+ my $timeout = shift;
+
+ my $key = $timeout->get_data;
+ $self->remove_timeout($key);
+ }, sub {
+ my $object = shift;
+ my $timeout = shift;
+
+ my $key = $timeout->get_data;
+ $self->remove_timeout($key,
+ $timeout->is_enabled,
+ $timeout->get_interval);
+ });
+ }
+
+ if ($object->can("dispatch")) {
+ $self->add_hook(DBus::Callback->new(object => $object,
+ method => "dispatch",
+ args => []),
+ 1);
+ }
}
-
-sub _manage_on {
+sub _manage_watch_on {
my $self = shift;
+ my $object = shift;
my $watch = shift;
my $flags = $watch->get_flags;
if ($flags & &DBus::Watch::READABLE) {
- $self->add_read($watch->get_fileno, $watch, "handle", [&DBus::Watch::READABLE], $watch->is_enabled);
+ $self->add_read($watch->get_fileno,
+ DBus::Callback->new(object => $watch,
+ method => "handle",
+ args => [&DBus::Watch::READABLE]),
+ $watch->is_enabled);
}
if ($flags & &DBus::Watch::WRITABLE) {
- $self->add_write($watch->get_fileno, $watch, "handle", [&DBus::Watch::WRITABLE], $watch->is_enabled);
+ $self->add_write($watch->get_fileno,
+ DBus::Callback->new(object => $watch,
+ method => "handle",
+ args => [&DBus::Watch::WRITABLE]),
+ $watch->is_enabled);
}
- $self->add_exception($watch->get_fileno, $watch, "handle", [&DBus::Watch::ERROR], $watch->is_enabled);
+# $self->add_exception($watch->get_fileno, $watch,
+# DBus::Callback->new(object => $watch,
+# method => "handle",
+# args => [&DBus::Watch::ERROR]),
+# $watch->is_enabled);
+
}
-sub _manage_off {
+sub _manage_watch_off {
my $self = shift;
+ my $object = shift;
my $watch = shift;
my $flags = $watch->get_flags;
@@ -75,11 +247,12 @@ sub _manage_off {
if ($flags & &DBus::Watch::WRITABLE) {
$self->remove_write($watch->get_fileno);
}
- $self->remove_exception($watch->get_fileno);
+# $self->remove_exception($watch->get_fileno);
}
-sub _manage_state {
+sub _manage_watch_toggle {
my $self = shift;
+ my $object = shift;
my $watch = shift;
my $flags = $watch->get_flags;
@@ -93,38 +266,93 @@ sub _manage_state {
}
+=pod
+
+=item $reactor->run();
+
+Starts the event loop monitoring any registered
+file handles and timeouts. At least one file
+handle, or timer must have been registered prior
+to running the reactor, otherwise it will immediately
+exit. The reactor will run until all registered
+file handles, or timeouts have been removed, or
+disabled. The reactor can be explicitly stopped by
+calling the C<shutdown> method.
+
+=cut
+
sub run {
my $self = shift;
- while ($self->step) {};
+ $self->{running} = 1;
+ while ($self->{running}) { $self->step };
+}
+
+=pod
+
+=item $reactor->shutdown();
+
+Explicitly shutdown the reactor after pending
+events have been processed.
+
+=cut
+
+sub shutdown {
+ my $self = shift;
+ $self->{running} = 0;
}
+=pod
+
+=item $reactor->step();
+
+Perform one iteration of the event loop, going to
+sleep until an event occurs on a registered file
+handle, or a timeout occurrs. This method is generally
+not required in day-to-day use.
+
+=cut
+
sub step {
my $self = shift;
my ($ri, $ric) = $self->_bits("read");
my ($wi, $wic) = $self->_bits("write");
my ($ei, $eic) = $self->_bits("exception");
- my ($ro, $wo, $eo);
+ my $timeout = $self->_timeout($self->_now);
- print "$ric $wic $eic\n";
-
- if (!$ric && !$wic && !$eic) {
- print "No handles to listen on. Exiting\n";
- return 0;
+ if (!$ric && !$wic && !$eic && !(defined $timeout)) {
+ $self->{running} = 0;
+ return;
}
-
- my ($n, $timeleft) = select($ro=$ri,$wo=$wi,$eo=$ei, undef);
+ my ($ro, $wo, $eo);
+ my $n = select($ro=$ri,$wo=$wi,$eo=$ei, (defined $timeout ? ($timeout ? $timeout/1000 : 0) : undef));
+
+ my @callbacks;
if ($n) {
- $self->_dispatch("read", $ro);
- $self->_dispatch("write", $wo);
- $self->_dispatch("error", $eo);
+ push @callbacks, $self->_dispatch_fd("read", $ro);
+ push @callbacks, $self->_dispatch_fd("write", $wo);
+ push @callbacks, $self->_dispatch_fd("error", $eo);
}
+ push @callbacks, $self->_dispatch_timeout($self->_now);
+ push @callbacks, $self->_dispatch_hook();
+ foreach my $callback (@callbacks) {
+ $callback->invoke;
+ }
+
return 1;
}
+sub _now {
+ my $self = shift;
+
+ my @now = gettimeofday;
+
+ return $now[0] * 1000 + (($now[1] - ($now[1] % 1000)) / 1000);
+}
+
sub _bits {
my $self = shift;
my $type = shift;
@@ -140,59 +368,303 @@ sub _bits {
return ($vec, $count);
}
-sub _dispatch {
+sub _timeout {
+ my $self = shift;
+ my $now = shift;
+
+ my $timeout;
+ foreach (@{$self->{timeouts}}) {
+ next unless $_->{enabled};
+
+ my $expired = $now - $_->{last_fired};
+ my $interval = ($expired > $_->{interval} ? 0 : $_->{interval} - $expired);
+ $timeout = $interval if !(defined $timeout) ||
+ ($interval < $timeout);
+ }
+ return $timeout;
+}
+
+
+sub _dispatch_fd {
my $self = shift;
my $type = shift;
my $vec = shift;
+
+ my @callbacks;
foreach my $fd (keys %{$self->{fds}->{$type}}) {
next unless $self->{fds}->{$type}->{$fd}->{enabled};
if (vec($vec, $fd, 1)) {
my $rec = $self->{fds}->{$type}->{$fd};
- my $object = $rec->{object};
- my $code = $rec->{code};
- my $args = $rec->{args};
- print "Dispatch $type on $fd to $object $code ", join(',', @{$args}), "\n";
+ push @callbacks, $self->{fds}->{$type}->{$fd}->{callback};
+ }
+ }
+ return @callbacks;
+}
- $object->$code(@{$args});
+
+sub _dispatch_timeout {
+ my $self = shift;
+ my $now = shift;
+
+ my @callbacks;
+ foreach my $timeout (@{$self->{timeouts}}) {
+ next unless $timeout->{enabled};
+ my $expired = $now - $timeout->{last_fired};
+
+ # Select typically returns a little (0-10 ms) before we
+ # asked it for. (8 milliseconds seems reasonable balance
+ # between early timeouts & extra select calls
+ if ($expired >= ($timeout->{interval}-8)) {
+ $timeout->{last_fired} = $now;
+ push @callbacks, $timeout->{callback};
}
}
+ return @callbacks;
}
+sub _dispatch_hook {
+ my $self = shift;
+ my $now = shift;
+
+ my @callbacks;
+ foreach my $hook (@{$self->{hooks}}) {
+ next unless $hook->{enabled};
+
+ push @callbacks, $hook->{callback};
+ }
+ return @callbacks;
+}
+
+
+=pod
+
+=item $reactor->add_read($fd, $callback[, $status]);
+
+Registers a file handle for monitoring of read
+events. The C<$callback> parameter specifies an
+instance of the C<DBus::Callback> object to invoke
+each time an event occurs. The optional C<$status>
+parameter is a boolean value to specify whether the
+watch is initially enabled.
+
+=cut
+
sub add_read {
my $self = shift;
$self->_add("read", @_);
}
+=pod
+
+=item $reactor->add_write($fd, $callback[, $status]);
+
+Registers a file handle for monitoring of write
+events. The C<$callback> parameter specifies an
+instance of the C<DBus::Callback> object to invoke
+each time an event occurs. The optional C<$status>
+parameter is a boolean value to specify whether the
+watch is initially enabled.
+
+=cut
+
sub add_write {
my $self = shift;
$self->_add("write", @_);
}
+=pod
+
+=item $reactor->add_exception($fd, $callback[, $status]);
+
+Registers a file handle for monitoring of exception
+events. The C<$callback> parameter specifies an
+instance of the C<DBus::Callback> object to invoke
+each time an event occurs. The optional C<$status>
+parameter is a boolean value to specify whether the
+watch is initially enabled.
+
+=cut
+
sub add_exception {
my $self = shift;
$self->_add("exception", @_);
}
+=pod
+
+=item my $id = $reactor->add_timeout($interval, $callback, $status);
+
+Registers a new timeout to expire every C<$interval>
+milliseconds. The C<$callback> parameter specifies an
+instance of the C<DBus::Callback> object to invoke
+each time the timeout expires. The optional C<$status>
+parameter is a boolean value to specify whether the
+timeout is initially enabled. The return parameter is
+a unique identifier which can be used to later remove
+or disable the timeout.
+
+=cut
+
+sub add_timeout {
+ my $self = shift;
+ my $interval = shift;
+ my $callback = shift;
+ my $enabled = shift;
+ $enabled = 1 unless defined $enabled;
+
+ my $key;
+ for (my $i = 0 ; $i <= $#{$self->{timeouts}} && !(defined $key); $i++) {
+ $key = $i unless defined $self->{timeouts}->[$i];
+ }
+ $key = $#{$self->{timeouts}}+1 unless defined $key;
+
+ $self->{timeouts}->[$key] = {
+ interval => $interval,
+ last_fired => $self->_now,
+ callback => $callback,
+ enabled => $enabled
+ };
+
+ return $key;
+}
+
+=pod
+
+=item $reactor->remove_timeout($id);
+
+Removes a previously registered timeout specified by
+the C<$id> parameter.
+
+=cut
+
+sub remove_timeout {
+ my $self = shift;
+ my $key = shift;
+
+ $self->{timeouts}->[$key] = undef;
+}
+
+=pod
+
+=item $reactor->toggle_timeout($id, $status[, $interval]);
+
+Updates the state of a previously registered timeout
+specifed by the C<$id> parameter. The C<$status>
+parameter specifies whether the timeout is to be enabled
+or disabled, while the optional C<$interval> parameter
+can be used to change the period of the timeout.
+
+=cut
+
+sub toggle_timeout {
+ my $self = shift;
+ my $key = shift;
+ my $enabled = shift;
+
+ $self->{timeouts}->[$key]->{enabled} = $enabled;
+ $self->{timeouts}->[$key]->{interval} = shift if @_;
+}
+
+
+=pod
+
+=item my $id = $reactor->add_hook($callback[, $status]);
+
+Registers a new hook to be fired on each iteration
+of the event loop. The C<$callback> parameter
+specifies an instance of the C<DBus::Callback>
+class to invoke. The C<$status> parameter determines
+whether the hook is initially enabled, or disabled.
+The return parameter is a unique id which should
+be used to later remove, or disable the hook.
+
+=cut
+
+sub add_hook {
+ my $self = shift;
+ my $callback = shift;
+ my $enabled = shift;
+ $enabled = 1 unless defined $enabled;
+
+ my $key;
+ for (my $i = 0 ; $i <= $#{$self->{hooks}} && !(defined $key); $i++) {
+ $key = $i unless defined $self->{hooks}->[$i];
+ }
+ $key = $#{$self->{hooks}}+1 unless defined $key;
+
+ $self->{hooks}->[$key] = {
+ callback => $callback,
+ enabled => $enabled
+ };
+
+ return $key;
+}
+
+
+=pod
+
+=item $reactor->remove_hook($id)
+
+Removes the previously registered hook identified
+by C<$id>.
+
+=cut
+
+sub remove_hook {
+ my $self = shift;
+ my $key = shift;
+
+ $self->{hooks}->[$key] = undef;
+}
+
+=pod
+
+=item $reactor->toggle_hook($id[, $status])
+
+Updates the status of the previously registered
+hook identified by C<$id>. The C<$status> parameter
+determines whether the hook is to be enabled or
+disabled.
+
+=cut
+
+sub toggle_hook {
+ my $self = shift;
+ my $key = shift;
+ my $enabled = shift;
+
+ $self->{hooks}->[$key]->{enabled} = $enabled;
+}
+
sub _add {
my $self = shift;
my $type = shift;
my $fd = shift;
- my $obj = shift;
- my $code = shift;
- my $args = shift;
+ my $callback = shift;
my $enabled = shift;
+ $enabled = 1 unless defined $enabled;
$self->{fds}->{$type}->{$fd} = {
- object => $obj,
- code => $code,
- args => $args,
+ callback => $callback,
enabled => $enabled
};
}
+=pod
+
+=item $reactor->remove_read($fd);
+
+=item $reactor->remove_write($fd);
+
+=item $reactor->remove_exception($fd);
+
+Removes a watch on the file handle C<$fd>.
+
+=cut
+
sub remove_read {
my $self = shift;
$self->_remove("read", @_);
@@ -216,6 +688,20 @@ sub _remove {
delete $self->{fds}->{$type}->{$fd};
}
+=pod
+
+=item $reactor->toggle_read($fd, $status);
+
+=item $reactor->toggle_write($fd, $status);
+
+=item $reactor->toggle_exception($fd, $status);
+
+Updates the status of a watch on the file handle C<$fd>.
+The C<$status> parameter species whether the watch is
+to be enabled or disabled.
+
+=cut
+
sub toggle_read {
my $self = shift;
$self->_toggle("read", @_);
@@ -242,4 +728,24 @@ sub _toggle {
1;
-__END__
+
+=pod
+
+=back
+
+=head1 SEE ALSO
+
+L<DBus::Callback>, L<DBus::Connection>, L<DBus::Server>
+
+=head1 AUTHOR
+
+Daniel Berrange E<lt>dan at berrange.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2004 by Daniel Berrange
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
diff --git a/lib/DBus/Server.pm b/lib/DBus/Server.pm
index 2f6a6f5..c27480a 100644
--- a/lib/DBus/Server.pm
+++ b/lib/DBus/Server.pm
@@ -2,17 +2,17 @@
=head1 NAME
-DBus::Connection - A connection between client and server
+DBus::Server - A server to accept incoming connections
=head1 SYNOPSIS
-Creating a server and accepting client connections
+Creating a new server and accepting client connections
use DBus::Server;
my $server = DBus::Server->new(address => "unix:path=/path/to/socket");
- $server->connection_callback(&new_connection);
+ $server->connection_callback(\&new_connection);
sub new_connection {
my $connection = shift;
@@ -20,9 +20,31 @@ Creating a server and accepting client connections
.. work with new connection...
}
+Managing the server and new connections in an event loop
+
+ my $reactor = DBus::Reactor->new();
+
+ $reactor->manage($server);
+ $reactor->run();
+
+ sub new_connection {
+ my $connection = shift;
+
+ $reactor->manage($connection);
+ }
+
+
=head1 DESCRIPTION
-A server for receiving connection from client programs
+A server for receiving connection from client programs.
+The methods defined on this module have a close
+correspondance to the dbus_server_XXX methods in the C API,
+so for further details on their behaviour, the C API documentation
+may be of use.
+
+=head1 METHODS
+
+=over
=cut
@@ -38,6 +60,15 @@ use DBus::Connection;
our $VERSION = '0.0.1';
+=pod
+
+=item my $server = DBus::Server->new(address => "unix:path=/path/to/socket");
+
+Creates a new server binding it to the socket specified by the
+C<address> parameter.
+
+=cut
+
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
@@ -49,6 +80,8 @@ sub new {
bless $self, $class;
+ $self->{server}->_set_owner($self);
+
$self->{_callback} = sub {
my $server = shift;
my $rawcon = shift;
@@ -62,6 +95,15 @@ sub new {
return $self;
}
+=pod
+
+=item $status = $server->is_connected();
+
+Returns zero if the server has been disconnected,
+otherwise a positive value is returned.
+
+=cut
+
sub is_connected {
my $self = shift;
@@ -69,6 +111,16 @@ sub is_connected {
return $self->{server}->dbus_server_get_is_connected();
}
+=pod
+
+=item $server->disconnect()
+
+Closes this server to the remote host. This method
+is called automatically during garbage collection (ie
+in the DESTROY method) if the programmer forgets to
+explicitly disconnect.
+
+=cut
sub disconnect {
my $self = shift;
@@ -76,6 +128,22 @@ sub disconnect {
return $self->{server}->dbus_server_disconnect();
}
+
+=pod
+
+=item $server->set_watch_callbacks(\&add_watch, \&remove_watch, \&toggle_watch);
+
+Register a set of callbacks for adding, removing & updating
+watches in the application's event loop. Each parameter
+should be a code reference, which on each invocation, will be
+supplied with two parameters, the server object and the
+watch object. If you are using a C<DBus::Reactor> object
+as the application event loop, then the 'manage' method on
+that object will call this on your behalf.
+
+=cut
+
+
sub set_watch_callbacks {
my $self = shift;
my $add = shift;
@@ -86,26 +154,56 @@ sub set_watch_callbacks {
$self->{remove_watch} = $remove;
$self->{toggled_watch} = $toggled;
- $self->{server}->_set_watch_callbacks($self);
+ $self->{server}->_set_watch_callbacks();
+}
+
+=pod
+
+=item $server->set_timeout_callbacks(\&add_timeout, \&remove_timeout, \&toggle_timeout);
+
+Register a set of callbacks for adding, removing & updating
+timeouts in the application's event loop. Each parameter
+should be a code reference, which on each invocation, will be
+supplied with two parameters, the server object and the
+timeout object. If you are using a C<DBus::Reactor> object
+as the application event loop, then the 'manage' method on
+that object will call this on your behalf.
+
+=cut
+
+sub set_timeout_callbacks {
+ my $self = shift;
+ my $add = shift;
+ my $remove = shift;
+ my $toggled = shift;
+
+ $self->{add_timeout} = $add;
+ $self->{remove_timeout} = $remove;
+ $self->{toggled_timeout} = $toggled;
+
+ $self->{server}->_set_timeout_callbacks();
}
+=pod
+
+=item $server->set_connection_callback(\&handler)
+
+Registers the handler to use for dealing with
+new incoming connections from clients. The code
+reference will be invoked each time a new client
+connects and supplied with a single parameter
+which is the C<DBus::Connection> object representing
+the client.
+
+=cut
+
sub set_connection_callback {
my $self = shift;
my $callback = shift;
$self->{connection_callback} = $callback;
- print("callback $self $callback\n");
- $self->{server}->_set_connection_callback($self);
-}
-sub DESTROY {
- my $self = shift;
-
- print "DESTROy $self $self->{server}\n";
- if ($self->{server}->dbus_server_get_is_connected()) {
- $self->{server}->dbus_server_disconnect();
- }
- $self->{server}->dbus_server_unref();
+ $self->{server}->_set_connection_callback();
}
@@ -114,6 +212,8 @@ sub DESTROY {
=pod
+=back
+
=head1 SEE ALSO
L<DBus::Connection>, L<DBus::Bus>, L<DBus::Message::Signal>, L<DBus::Message::MethodCall>, L<DBus::Message::MethodReturn>, L<DBus::Message::Error>
diff --git a/rollingbuild.sh b/rollingbuild.sh
new file mode 100755
index 0000000..9745813
--- /dev/null
+++ b/rollingbuild.sh
@@ -0,0 +1,21 @@
+#!/bin/sh
+#
+# This script is used to Test::AutoBuild (http://www.autobuild.org)
+# to perform automated builds of the DBus module
+
+set -e
+
+make -k realclean
+rm -rf MANIFEST blib pm_to_blib
+
+perl Makefile.PL
+make manifest
+
+make
+make test
+
+make install
+
+rm -f DBus-*.tar.gz
+make dist
+
diff --git a/typemap b/typemap
index e2428e4..d4ce9fc 100644
--- a/typemap
+++ b/typemap
@@ -3,13 +3,14 @@ DBusConnection* O_OBJECT_connection
DBusServer* O_OBJECT_server
DBusMessage* O_OBJECT_message
DBusWatch* O_OBJECT_watch
+DBusTimeout* O_OBJECT_timeout
DBusMessageIter* O_OBJECT_messageiter
DBusBusType T_IV
-dbus_bool_t T_IV
+dbus_bool_t T_BOOL
dbus_int32_t T_IV
-dbus_uint32_t T_IV
+dbus_uint32_t T_UV
dbus_int64_t T_IV
-dbus_uint64_t T_IV
+dbus_uint64_t T_UV
INPUT
O_OBJECT_connection
@@ -65,6 +66,19 @@ O_OBJECT_watch
sv_setref_pv( $arg, "DBus::C::Watch", (void*)$var );
INPUT
+O_OBJECT_timeout
+ if (sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG))
+ $var = ($type)SvIV((SV*)SvRV( $arg ));
+ else {
+ warn( \"${Package}::$func_name() -- $var is not a blessed SV reference\" );
+ XSRETURN_UNDEF;
+ }
+
+OUTPUT
+O_OBJECT_timeout
+ sv_setref_pv( $arg, "DBus::C::Timeout", (void*)$var );
+
+INPUT
O_OBJECT_messageiter
if (sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG))
$var = ($type)SvIV((SV*)SvRV( $arg ));
@@ -75,4 +89,4 @@ O_OBJECT_messageiter
OUTPUT
O_OBJECT_messageiter
- sv_setref_pv( $arg, "DBus::C::MessageIter", (void*)$var );
+ sv_setref_pv( $arg, "DBus::Iterator", (void*)$var );
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libnet-dbus-perl.git
More information about the Pkg-perl-cvs-commits
mailing list