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 <[email protected]> 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 <[email protected]>') : ()), - '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 <[email protected]>', + '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>[email protected]<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 _______________________________________________ Pkg-perl-cvs-commits mailing list [email protected] http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits
