From: Anas Nashif Date: Fri, 28 Dec 2012 02:52:17 +0000 (-0800) Subject: Imported Upstream version 1.0.0 X-Git-Tag: upstream/1.0.0^0 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=afbb1c8ef6bdd7661fa327e8f7bf58b523eb1351;p=platform%2Fupstream%2Fperl-Net-DBus.git Imported Upstream version 1.0.0 --- afbb1c8ef6bdd7661fa327e8f7bf58b523eb1351 diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 0000000..dd23fc4 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,22 @@ + Net::DBus - Perl APIs for DBus + ============================== + +Net::DBus is written by + + Daniel Berrange + +With patches, contributions & suggestions gratefully received +from + + Carlos Garnacho + Emmanuele Bassi + Olivier Blin + Jack + Dave Belser + Stefan Pfetzing + Pavel Strashkin + Mathieu Bridon + + [...send patches to get your name here!] + +-- End diff --git a/CHANGES b/CHANGES new file mode 100644 index 0000000..cff1d7d --- /dev/null +++ b/CHANGES @@ -0,0 +1,267 @@ + +New in 1.0.0: + + - Updated to require minimum dbus >= 1.0.0 + - Automatically track change in ownership of bus names + for signal handlers + - Strict validation of method invocation against introspection + data on exported objects + - Improved error messages for invalid interfaces + - Add API for disconnecting an object from a signal + - Implement GetAll methods on properties interface + - Allow leading _ in interface names + - Other minor fixes + +Changes since 0.33.5 + + - Fix introspection XML handling when exporting objects with child + objects + + - Improve output of Net::DBus::Dumper + + - Add support for providing parameter & return value names in + introspection XML + + - Fixes to marshalling of variants + + - Fix handling of compound data types within object properties + + - Remove non-portable makefile rules + + - Fix ref counting bugs in error path. + +Changes since 0.33.4 + + - Added support for getting private bus connections for apps which + don't want to deal with a shared bus + + - Fix test case to use a private connection + + - On Perl builds where integers are 32-bits, the DBus 64 bit integer + types will be serialized to/from the Perl String type instead of + calling 'die'. + + - Fix signature when marshalling dicts on newer DBus builds + + - Fix calling of disconnect wrt to newer DBus semantics + + - Make introspection much more tolerant of missing information + about methods/properties/signals. + + - Fix use of magic values & added tests + + - Export the Net::DBus::Dumper methods correctly. + +Changes since 0.33.3 + + - Fixed service owner used for org.freedesktop.DBus object + to make signal handling on the bus work again + + - Pass return value for signal handling callbacks all the + way back to DBus + + - Fix multiple problems with marshalling of variant data + types + + - Replace use of dbus_connection_disconnect with _close + when compiling against dbus >= 0.90 + + - Call dbus_connection_unref in the DESTROY method of + connection object + + - Fix reference counting in connection & pending call + objects + + - Added example of galago desktop notifications + + - Fix test suite errors + + - Added missing import statement + + - Throw Net::DBus::Error if an async call fails + +Changes since 0.33.2 + + - Fixed parsing of introspection data if there are processing + instructions, or other non-data nodes before the root element. + + - Replace use of XML::Grove with XML::Twig when parsing the + introspection XML documents, since the former has not had any + updates / bug fixes since 1999(!), and several people have + reported problems using it on Perl 5.8.x + + - Made all Perl scripts / modules / tests use 'strict' and + 'warnings' pragmas + + - Turn Net::DBus::Error into fully fledged object which services + can sub-class to allow explicit error handling by clients. + + - In _dispatch method of Net::DBus::Object ensure that any + instances of Net::DBus::Error thrown by the method call + are explicitly serialized into DBus errors, rather than + a generic 'org.freedesktop.DBus.Failed'. + + - Change re-distribution license from GPL, to GPL / Perl Artistic, + matching the terms of Perl itself. + + - Add support for registering a callback on Net::DBus::ASyncReply + objects to allow notification of completion for asynchronous + method calls + +Changes since 0.33.1 + + - Fixed handling of variants in introspection data + + - Added binding for the DBusPendingCall C object + + - Added some missing RPM dependancies on XML libs, and on minimum + required dbus version + + - Added support for doing asynchronous method calls, and fire-and- + forgot calls for methods whose return status is not desired. Use + the constants in Net::DBus::Annotation module to indicate desired + call mode. Default is to do synchronous blocking calls. + + - Added support for the 16-bit integer, signature and object path + data types + + - Made introspection of root objects compliant with upsteam spec, + by calling introspect on the root object, "/", rather than a + Perl specific magic object path. + +Changes since 0.32.3 + + - Constructor for Net::DBus::Object allows another Net::DBus::Object + to be passed instead of the Net::DBus::Service, to create child + objects specifying only a relative path. + + - Updated minimum required DBus version to be 0.33 to gain access + to the unregister_object_path API + + - Add a disconnect() method to Net::DBus::Object to make it possible + to unregister object from the bus & thus make it possible to destroy + objects which are no longer required / relevant. + + - Unregister all child objects if we are unregistered ourselves + + - Fix numerous POD errors identified by Test::Pod and podchecker + + - Increase POD documentation to get 100% coverage of all APIs, + verified by Test::Pod::Coverage + +Changes since 0.32.2 + + - Introspection data is used only as hint, so if an object + exports many methods, but only provides partial introspection + data, remote calls fallback to regular typing rules + + - Re-add dbus_XXX convenience methods to Net::DBus to allow + clients to do explicit type casting. Must be requested at + export time, using 'Net::DBus qw(:typing)'. + + - Update all example programs to run against session bus, + since there are no security rules to enable them to work + on system bus. + + - Print out warning upon use, if a method, signal, or property + is annotated with the 'org.freedesktop.DBus.Deprecated' flag. + + - Do not wait for a method reply if the method is annotated + with the 'org.freedesktop.DBus.Method.NoReply' flag. + + - Extend Net::DBus::Exporter to enable methods, signals, and + properties to be annotated. + + - Add support for 'org.freedesktop.DBus.Method.NoReply' and + 'org.freedesktop.DBus.Deprecated' annotations when exporting + objects + + - Add a pure in-memory bus implementation for facilitating + creation of unit tests which would otherwise require making + a connection to a 'live' message bus. Can be accessed via: + + Net::DBus->test + + - Add an *EXPERIMENTAL* mock object to faciltate creation of + unit tests which need to communicate with other objects on + the bus. See Net::DBus::Test::MockObject for further info. + +Changes since 0.32.1 + + - Fix unit tests broken in previous build + + - Added patch to avoid leaking memory when throwing dbus + errors from the XS layer + + - Added support for org.freedesktop.DBus.Properties + in exported & remote objects. + + - Added support for getting the unique name of the client's + connection to the bus + + - Added support for getting the unique name of the client + owning a service on the bus + + - RemoteService object constructor gains an extra parameter + for the owner of the service at the time it was aquired to + deal with issues where a service is replaced. + + - Cache RemoteService objects to avoid creating multiple + instances for the same service name. + + - Fix caching of objects by the service to avoid caching + objects cast to a specific interface + + - Make add_signal_receiver method on Net::DBus private + + - Use introspection data for hinting only, not absolute truth + since Python bindings don't provide complete data. + + - Adding correct handling for (de)marshalling variant data + type to fix interaction with python bindings + + - Added magic 'caller' and 'serial' data types for requesting + that data about method caller be passed into a method + + - Lots more POD documentation + + - Added 'lshal.pl' demo script for listing HAL devices + + - Made example scripts interoperate correctly with example + scripts from Python & GLib bindings + +Changes since 0.32.0 + + - The order of 'service_name' and 'bus' parameter to the + Net::DBus::Service constructor is reversed to match + that of Net::DBus::RemoteService + + - The order of 'service' and 'object_path' parameter to the + Net::DBus::Object constructor is reversed to match + that of Net::DBus::RemoteObject + + - No longer neccessary to construct an explicit Net::DBus::Service + object - one is constructed & returned by the 'export_service' + method on Net::DBus + + - The 'find' method on Net::DBus will search for & attach to + a suitable bus, so no longer neccessary to hard code either + system or session bus + + - Introspection data is no longer provided via the + Net::DBus::Object constructor. Consult the manual pages + for Net::DBus::OBject and Net::DBus::Exporter for details + of new approach to defining introspection data. + + - The Net::DBus::Introspector class is no longer for public + use. + + - The Net::DBus::Dumper class can be used to display a dump + of an object's exported API cf examples/dump-object.pl + + - Signal handler callbacks now get the actual signal params + passed in, rather than low level bind info + + - The Net::DBus objects are automatically registered with + the default reactor mainloop, unless 'nomainloop => 1' + is passed into constructor diff --git a/DBus.xs b/DBus.xs new file mode 100644 index 0000000..4291759 --- /dev/null +++ b/DBus.xs @@ -0,0 +1,1563 @@ +/* -*- c -*- + * + * Copyright (C) 2004-2011 Daniel P. Berrange + * + * This program is free software; You can redistribute it and/or modify + * it under the same terms as Perl itself. Either: + * + * a) the GNU General Public License as published by the Free + * Software Foundation; either version 2, or (at your option) any + * later version, + * + * or + * + * b) the "Artistic License" + * + * The file "COPYING" distributed along with this file provides full + * details of the terms and conditions of the two licenses. + */ + +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#include + +#if NET_DBUS_DEBUG +static int net_dbus_debug = 0; +#define DEBUG_MSG(...) if (net_dbus_debug) fprintf(stderr, __VA_ARGS__) +#else +#define DEBUG_MSG(...) +#endif + +#ifdef __GNUC__ +# define ignore_value(x) (({ __typeof__ (x) __x = (x); (void) __x; })) +#else +# define ignore_value(x) x +#endif + +/* + * On 32-bit OS (and some 64-bit) Perl does not have an + * integer type capable of storing 64 bit numbers. So + * we serialize to/from strings on these platforms + */ + +dbus_int64_t +_dbus_parse_int64(SV *sv) { +#ifdef USE_64_BIT_ALL + return SvIV(sv); +#else + //DEBUG_MSG("Parrse %s\n", SvPV_nolen(sv)); + return strtoll(SvPV_nolen(sv), NULL, 10); +#endif +} + +dbus_uint64_t +_dbus_parse_uint64(SV *sv) { +#ifdef USE_64_BIT_ALL + return SvUV(sv); +#else + //DEBUG_MSG("Parrse %s\n", SvPV_nolen(sv)); + return strtoull(SvPV_nolen(sv), NULL, 10); +#endif +} + + +#ifndef PRId64 +#define PRId64 "lld" +#endif + +SV * +_dbus_format_int64(dbus_int64_t val) { +#ifdef USE_64_BIT_ALL + return newSViv(val); +#else + char buf[100]; + int len; + len = snprintf(buf, 100, "%" PRId64, val); + //DEBUG_MSG("Format i64 [%" PRId64 "] to [%s]\n", val, buf); + return newSVpv(buf, len); +#endif +} + +#ifndef PRIu64 +#define PRIu64 "llu" +#endif + +SV * +_dbus_format_uint64(dbus_uint64_t val) { +#ifdef USE_64_BIT_ALL + return newSVuv(val); +#else + char buf[100]; + int len; + len = snprintf(buf, 100, "%" PRIu64, val); + //DEBUG_MSG("Format u64 [%" PRIu64 "] to [%s]\n", val, buf); + return newSVpv(buf, len); +#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; +dbus_int32_t pending_call_data_slot = -1; + +void +_object_release(void *obj) { + DEBUG_MSG("Releasing object count on %p\n", obj); + SvREFCNT_dec((SV*)obj); +} + +dbus_bool_t +_watch_generic(DBusWatch *watch, void *data, char *key, dbus_bool_t server) { + SV *selfref; + HV *self; + SV **call; + SV *h_sv; + dSP; + + DEBUG_MSG("Watch generic callback %p %p %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); + + DEBUG_MSG("Got owner %p\n", self); + + call = hv_fetch(self, key, strlen(key), 0); + + if (!call) { + warn("Could not find watch callback %s for fd %d\n", + key, dbus_watch_get_unix_fd(watch)); + return FALSE; + } + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(selfref); + h_sv = sv_newmortal(); + sv_setref_pv(h_sv, "Net::DBus::Binding::C::Watch", (void*)watch); + XPUSHs(h_sv); + PUTBACK; + + call_sv(*call, G_DISCARD); + + FREETMPS; + LEAVE; + + return 1; +} + +dbus_bool_t +_watch_server_add(DBusWatch *watch, void *data) { + return _watch_generic(watch, data, "add_watch", 1); +} +void +_watch_server_remove(DBusWatch *watch, void *data) { + _watch_generic(watch, data, "remove_watch", 1); +} +void +_watch_server_toggled(DBusWatch *watch, void *data) { + _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_sv; + 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_sv = sv_newmortal(); + sv_setref_pv(h_sv, "Net::DBus::Binding::C::Timeout", (void*)timeout); + XPUSHs(h_sv); + PUTBACK; + + call_sv(*call, G_DISCARD); + + FREETMPS; + LEAVE; + + return 1; +} + +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) { + SV *selfref = (SV*)dbus_server_get_data((DBusServer*)data, server_data_slot); + HV *self = (HV*)SvRV(selfref); + SV **call; + SV *value; + dSP; + + call = hv_fetch(self, "_callback", strlen("_callback"), 0); + + if (!call) { + warn("Could not find new connection callback\n"); + return; + } + + DEBUG_MSG("Created connection in callback %p\n", new_connection); + /* The DESTROY method will de-ref it later */ + dbus_connection_ref(new_connection); + + value = sv_newmortal(); + sv_setref_pv(value, "Net::DBus::Binding::C::Connection", (void*)new_connection); + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(selfref); + XPUSHs(value); + PUTBACK; + + call_sv(*call, G_DISCARD); + + FREETMPS; + LEAVE; +} + + +DBusHandlerResult +_message_filter(DBusConnection *con, + DBusMessage *msg, + void *data) { + SV *selfref; + SV *value; + int count; + int handled = 0; + dSP; + + selfref = (SV*)dbus_connection_get_data(con, connection_data_slot); + + DEBUG_MSG("Create message in filter %p\n", msg); + DEBUG_MSG(" Type %d\n", dbus_message_get_type(msg)); + DEBUG_MSG(" Interface %s\n", dbus_message_get_interface(msg) ? dbus_message_get_interface(msg) : ""); + DEBUG_MSG(" Path %s\n", dbus_message_get_path(msg) ? dbus_message_get_path(msg) : ""); + DEBUG_MSG(" Member %s\n", dbus_message_get_member(msg) ? dbus_message_get_member(msg) : ""); + /* Will be de-refed in the DESTROY method */ + dbus_message_ref(msg); + value = sv_newmortal(); + sv_setref_pv(value, "Net::DBus::Binding::C::Message", (void*)msg); + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs((SV*)selfref); + XPUSHs(value); + XPUSHs(data); + PUTBACK; + + count = call_method("_message_filter", G_SCALAR); + SPAGAIN; + if (count == 1) { + handled = POPi; + } else { + handled = 0; + } + PUTBACK; + DEBUG_MSG("Handled %d %d\n", count, handled); + FREETMPS; + LEAVE; + + return handled ? DBUS_HANDLER_RESULT_HANDLED : DBUS_HANDLER_RESULT_NOT_YET_HANDLED; +} + +void +_pending_call_callback(DBusPendingCall *call, + void *data) { + SV *selfref; + dSP; + + DEBUG_MSG("In pending call callback %p\n", call); + selfref = (SV*)dbus_pending_call_get_data(call, pending_call_data_slot); + + dbus_pending_call_ref(call); + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs((SV*)selfref); + PUTBACK; + + call_sv(data, G_DISCARD); + + FREETMPS; + LEAVE; +} + +void +_filter_release(void *data) { + SvREFCNT_dec(data); +} + +void +_pending_call_notify_release(void *data) { + SvREFCNT_dec(data); +} + +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; + + DEBUG_MSG("Got message in callback %p\n", msg); + DEBUG_MSG(" Type %d\n", dbus_message_get_type(msg)); + DEBUG_MSG(" Interface %s\n", dbus_message_get_interface(msg) ? dbus_message_get_interface(msg) : ""); + DEBUG_MSG(" Path %s\n", dbus_message_get_path(msg) ? dbus_message_get_path(msg) : ""); + DEBUG_MSG(" Member %s\n", dbus_message_get_member(msg) ? dbus_message_get_member(msg) : ""); + /* Will be de-refed in the DESTROY method */ + dbus_message_ref(msg); + value = sv_newmortal(); + sv_setref_pv(value, "Net::DBus::Binding::C::Message", (void*)msg); + + ENTER; + SAVETMPS; + + PUSHMARK(SP); + XPUSHs(self); + XPUSHs(value); + PUTBACK; + + call_sv((SV*)data, G_DISCARD); + + FREETMPS; + LEAVE; + + return DBUS_HANDLER_RESULT_HANDLED; +} + +DBusObjectPathVTable _path_callback_vtable = { + _path_unregister_callback, + _path_message_callback, + NULL, + NULL, + NULL, + NULL +}; + +SV * +_sv_from_error (DBusError *error) +{ + HV *hv; + + if (!error) { + warn ("error is NULL"); + return &PL_sv_undef; + } + + if (!dbus_error_is_set (error)) { + warn ("error is unset"); + return &PL_sv_undef; + } + + hv = newHV (); + + /* map DBusError attributes to hash keys */ + ignore_value(hv_store (hv, "name", 4, newSVpv (error->name, 0), 0)); + ignore_value(hv_store (hv, "message", 7, newSVpv (error->message, 0), 0)); + + return sv_bless (newRV_noinc ((SV*) hv), gv_stashpv ("Net::DBus::Error", TRUE)); +} + +void +_croak_error (DBusError *error) +{ + sv_setsv (ERRSV, _sv_from_error (error)); + + /* croak does not return, so we free this now to avoid leaking */ + dbus_error_free (error); + + croak (Nullch); +} + +void +_populate_constant(HV *href, char *name, int val) +{ + ignore_value(hv_store(href, name, strlen(name), newSViv(val), 0)); +} + +#define REGISTER_CONSTANT(name, key) _populate_constant(constants, #key, name) + +MODULE = Net::DBus PACKAGE = Net::DBus + +PROTOTYPES: ENABLE +BOOT: + { + HV *constants; + + if (getenv("NET_DBUS_DEBUG")) + net_dbus_debug = 1; + + /* not the 'standard' way of doing perl constants, but a lot easier to maintain */ + + constants = perl_get_hv("Net::DBus::Binding::Bus::_constants", TRUE); + REGISTER_CONSTANT(DBUS_BUS_SYSTEM, SYSTEM); + REGISTER_CONSTANT(DBUS_BUS_SESSION, SESSION); + REGISTER_CONSTANT(DBUS_BUS_STARTER, STARTER); + + constants = perl_get_hv("Net::DBus::Binding::Message::_constants", TRUE); + REGISTER_CONSTANT(DBUS_TYPE_ARRAY, TYPE_ARRAY); + REGISTER_CONSTANT(DBUS_TYPE_BOOLEAN, TYPE_BOOLEAN); + REGISTER_CONSTANT(DBUS_TYPE_BYTE, TYPE_BYTE); + REGISTER_CONSTANT(DBUS_TYPE_DOUBLE, TYPE_DOUBLE); + REGISTER_CONSTANT(DBUS_TYPE_INT16, TYPE_INT16); + REGISTER_CONSTANT(DBUS_TYPE_INT32, TYPE_INT32); + REGISTER_CONSTANT(DBUS_TYPE_INT64, TYPE_INT64); + REGISTER_CONSTANT(DBUS_TYPE_INVALID, TYPE_INVALID); + REGISTER_CONSTANT(DBUS_TYPE_STRUCT, TYPE_STRUCT); + REGISTER_CONSTANT(DBUS_TYPE_SIGNATURE, TYPE_SIGNATURE); + REGISTER_CONSTANT(DBUS_TYPE_OBJECT_PATH, TYPE_OBJECT_PATH); + REGISTER_CONSTANT(DBUS_TYPE_DICT_ENTRY, TYPE_DICT_ENTRY); + REGISTER_CONSTANT(DBUS_TYPE_STRING, TYPE_STRING); + REGISTER_CONSTANT(DBUS_TYPE_UINT16, TYPE_UINT16); + REGISTER_CONSTANT(DBUS_TYPE_UINT32, TYPE_UINT32); + REGISTER_CONSTANT(DBUS_TYPE_UINT64, TYPE_UINT64); + REGISTER_CONSTANT(DBUS_TYPE_VARIANT, TYPE_VARIANT); + + REGISTER_CONSTANT(DBUS_MESSAGE_TYPE_METHOD_CALL, MESSAGE_TYPE_METHOD_CALL); + REGISTER_CONSTANT(DBUS_MESSAGE_TYPE_METHOD_RETURN, MESSAGE_TYPE_METHOD_RETURN); + REGISTER_CONSTANT(DBUS_MESSAGE_TYPE_ERROR, MESSAGE_TYPE_ERROR); + REGISTER_CONSTANT(DBUS_MESSAGE_TYPE_SIGNAL, MESSAGE_TYPE_SIGNAL); + REGISTER_CONSTANT(DBUS_MESSAGE_TYPE_INVALID, MESSAGE_TYPE_INVALID); + + constants = perl_get_hv("Net::DBus::Binding::Watch::_constants", TRUE); + REGISTER_CONSTANT(DBUS_WATCH_READABLE, READABLE); + 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); + dbus_pending_call_allocate_data_slot(&pending_call_data_slot); + } + + +MODULE = Net::DBus::Binding::Connection PACKAGE = Net::DBus::Binding::Connection + +PROTOTYPES: ENABLE + +DBusConnection * +_open(address) + char *address; + PREINIT: + DBusError error; + DBusConnection *con; + CODE: + dbus_error_init(&error); + DEBUG_MSG("Open connection shared %s\n", address); + con = dbus_connection_open(address, &error); + if (!con) { + _croak_error (&error); + } + dbus_connection_ref(con); + RETVAL = con; + OUTPUT: + RETVAL + +DBusConnection * +_open_private(address) + char *address; + PREINIT: + DBusError error; + DBusConnection *con; + CODE: + dbus_error_init(&error); + DEBUG_MSG("Open connection private %s\n", address); + con = dbus_connection_open_private(address, &error); + if (!con) { + _croak_error (&error); + } + dbus_connection_ref(con); + RETVAL = con; + OUTPUT: + RETVAL + +MODULE = Net::DBus::Binding::C::Connection PACKAGE = Net::DBus::Binding::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; + CODE: + DEBUG_MSG("Closing connection %p\n", con); + dbus_connection_close(con); + +void +dbus_connection_ref(con) + DBusConnection *con; + +void +dbus_connection_unref(con) + DBusConnection *con; + +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; + +int +_send(con, msg) + DBusConnection *con; + DBusMessage *msg; + PREINIT: + dbus_uint32_t serial; + CODE: + if (!dbus_connection_send(con, msg, &serial)) { + croak("not enough memory to send message"); + } + RETVAL = serial; + OUTPUT: + RETVAL + +DBusMessage * +_send_with_reply_and_block(con, msg, timeout) + DBusConnection *con; + DBusMessage *msg; + int timeout; + PREINIT: + DBusMessage *reply; + DBusError error; + CODE: + dbus_error_init(&error); + if (!(reply = dbus_connection_send_with_reply_and_block(con, msg, timeout, &error))) { + _croak_error(&error); + } + DEBUG_MSG("Create msg reply %p\n", reply); + DEBUG_MSG(" Type %d\n", dbus_message_get_type(reply)); + DEBUG_MSG(" Interface %s\n", dbus_message_get_interface(reply) ? dbus_message_get_interface(reply) : ""); + DEBUG_MSG(" Path %s\n", dbus_message_get_path(reply) ? dbus_message_get_path(reply) : ""); + DEBUG_MSG(" Member %s\n", dbus_message_get_member(reply) ? dbus_message_get_member(reply) : ""); + RETVAL = reply; + OUTPUT: + RETVAL + + +DBusPendingCall * +_send_with_reply(con, msg, timeout) + DBusConnection *con; + DBusMessage *msg; + int timeout; + PREINIT: + DBusPendingCall *reply; + CODE: + if (!dbus_connection_send_with_reply(con, msg, &reply, timeout)) { + croak("not enough memory to send message"); + } + DEBUG_MSG("Create pending call %p\n", reply); + 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: + DEBUG_MSG("IN dispatch\n"); + while(dbus_connection_dispatch(con) == DBUS_DISPATCH_DATA_REMAINS); + DEBUG_MSG("Completed \n"); + +void +_set_watch_callbacks(con) + DBusConnection *con; + CODE: + if (!dbus_connection_set_watch_functions(con, + _watch_connection_add, + _watch_connection_remove, + _watch_connection_toggled, + con, NULL)) { + croak("not enough memory to set watch functions on connection"); + } + +void +_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_object_path(con, path, code) + DBusConnection *con; + char *path; + SV *code; + CODE: + SvREFCNT_inc(code); + if (!(dbus_connection_register_object_path(con, path, &_path_callback_vtable, code))) { + croak("failure when registering object path"); + } + +void +_unregister_object_path(con, path) + DBusConnection *con; + char *path; + CODE: + /* The associated data will be free'd by the previously + registered callback */ + if (!(dbus_connection_unregister_object_path(con, path))) { + croak("failure when unregistering object path"); + } + +void +_register_fallback(con, path, code) + DBusConnection *con; + char *path; + SV *code; + CODE: + SvREFCNT_inc(code); + if (!(dbus_connection_register_fallback(con, path, &_path_callback_vtable, code))) { + croak("failure when registering fallback object path"); + } + + +void +_add_filter(con, code) + DBusConnection *con; + SV *code; + CODE: + SvREFCNT_inc(code); + DEBUG_MSG("Adding filter %p\n", code); + dbus_connection_add_filter(con, _message_filter, code, _filter_release); + +dbus_bool_t +dbus_bus_register(con) + DBusConnection *con; + PREINIT: + DBusError error; + int reply; + CODE: + dbus_error_init(&error); + if (!(reply = dbus_bus_register(con, &error))) { + _croak_error(&error); + } + RETVAL = reply; + OUTPUT: + RETVAL + +void +dbus_bus_add_match(con, rule) + DBusConnection *con; + char *rule; + PREINIT: + DBusError error; + CODE: + dbus_error_init(&error); + DEBUG_MSG("Adding match %s\n", rule); + dbus_bus_add_match(con, rule, &error); + if (dbus_error_is_set(&error)) { + _croak_error(&error); + } + +void +dbus_bus_remove_match(con, rule) + DBusConnection *con; + char *rule; + PREINIT: + DBusError error; + CODE: + dbus_error_init(&error); + DEBUG_MSG("Removeing match %s\n", rule); + dbus_bus_remove_match(con, rule, &error); + if (dbus_error_is_set(&error)) { + _croak_error(&error); + } + +const char * +dbus_bus_get_unique_name(con) + DBusConnection *con; + +int +dbus_bus_request_name(con, service_name) + DBusConnection *con; + char *service_name; + PREINIT: + DBusError error; + int reply; + CODE: + dbus_error_init(&error); + if (!(reply = dbus_bus_request_name(con, service_name, 0, &error))) { + _croak_error(&error); + } + RETVAL = reply; + OUTPUT: + RETVAL + +void +DESTROY(con) + DBusConnection *con; + CODE: + DEBUG_MSG("Unrefing connection %p\n", con); + dbus_connection_unref(con); + + +MODULE = Net::DBus::Binding::Server PACKAGE = Net::DBus::Binding::Server + +PROTOTYPES: ENABLE + +DBusServer * +_open(address) + char *address; + PREINIT: + DBusError error; + DBusServer *server; + CODE: + dbus_error_init(&error); + server = dbus_server_listen(address, &error); + DEBUG_MSG("Created server %p on address %s\n", server, address); + if (!server) { + _croak_error(&error); + } + if (!dbus_server_set_auth_mechanisms(server, NULL)) { + croak("not enough memory to server auth mechanisms"); + } + RETVAL = server; + OUTPUT: + RETVAL + + +MODULE = Net::DBus::Binding::C::Server PACKAGE = Net::DBus::Binding::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; + +int +dbus_server_get_is_connected(server) + DBusServer *server; + +void +_set_watch_callbacks(server) + DBusServer *server; + CODE: + if (!dbus_server_set_watch_functions(server, + _watch_server_add, + _watch_server_remove, + _watch_server_toggled, + server, NULL)) { + croak("not enough memory to set watch functions on server"); + } + + +void +_set_timeout_callbacks(server) + DBusServer *server; + 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, + server, NULL); + +void +DESTROY(server) + DBusServer *server; + CODE: + DEBUG_MSG("Destroying server %p\n", server); + dbus_server_unref(server); + + +MODULE = Net::DBus::Binding::Bus PACKAGE = Net::DBus::Binding::Bus + +PROTOTYPES: ENABLE + +DBusConnection * +_open(type) + DBusBusType type; + PREINIT: + DBusError error; + DBusConnection *con; + CODE: + dbus_error_init(&error); + DEBUG_MSG("Open bus shared %d\n", type); + con = dbus_bus_get(type, &error); + if (!con) { + _croak_error(&error); + } + dbus_connection_ref(con); + RETVAL = con; + OUTPUT: + RETVAL + +DBusConnection * +_open_private(type) + DBusBusType type; + PREINIT: + DBusError error; + DBusConnection *con; + CODE: + dbus_error_init(&error); + DEBUG_MSG("Open bus private %d\n", type); + con = dbus_bus_get_private(type, &error); + if (!con) { + _croak_error(&error); + } + dbus_connection_ref(con); + RETVAL = con; + OUTPUT: + RETVAL + +MODULE = Net::DBus::Binding::Message PACKAGE = Net::DBus::Binding::Message + +PROTOTYPES: ENABLE + +DBusMessage * +_create(type) + IV type; + PREINIT: + DBusMessage *msg; + CODE: + msg = dbus_message_new(type); + if (!msg) { + croak("No memory to allocate message"); + } + DEBUG_MSG("Create msg new %p\n", msg); + DEBUG_MSG(" Type %d\n", dbus_message_get_type(msg)); + RETVAL = msg; + OUTPUT: + RETVAL + + +DBusMessageIter * +_iterator_append(msg) + DBusMessage *msg; + CODE: + RETVAL = dbus_new(DBusMessageIter, 1); + dbus_message_iter_init_append(msg, RETVAL); + OUTPUT: + RETVAL + + +DBusMessageIter * +_iterator(msg) + DBusMessage *msg; + CODE: + RETVAL = dbus_new(DBusMessageIter, 1); + dbus_message_iter_init(msg, RETVAL); + OUTPUT: + RETVAL + + +MODULE = Net::DBus::Binding::C::Message PACKAGE = Net::DBus::Binding::C::Message + +void +DESTROY(msg) + DBusMessage *msg; + CODE: + DEBUG_MSG("De-referencing message %p\n", msg); + DEBUG_MSG(" Type %d\n", dbus_message_get_type(msg)); + DEBUG_MSG(" Interface %s\n", dbus_message_get_interface(msg) ? dbus_message_get_interface(msg) : ""); + DEBUG_MSG(" Path %s\n", dbus_message_get_path(msg) ? dbus_message_get_path(msg) : ""); + DEBUG_MSG(" Member %s\n", dbus_message_get_member(msg) ? dbus_message_get_member(msg) : ""); + dbus_message_unref(msg); + +dbus_bool_t +dbus_message_get_no_reply(msg) + DBusMessage *msg; + +void +dbus_message_set_no_reply(msg,flag) + DBusMessage *msg; + dbus_bool_t flag; + +int +dbus_message_get_type(msg) + DBusMessage *msg; + +const char * +dbus_message_get_interface(msg) + DBusMessage *msg; + +const char * +dbus_message_get_path(msg) + DBusMessage *msg; + +const char * +dbus_message_get_destination(msg) + DBusMessage *msg; + +const char * +dbus_message_get_sender(msg) + DBusMessage *msg; + +dbus_uint32_t +dbus_message_get_serial(msg) + DBusMessage *msg; + +const char * +dbus_message_get_member(msg) + DBusMessage *msg; + +const char * +dbus_message_get_error_name(msg) + DBusMessage *msg; + +const char * +dbus_message_get_signature(msg) + DBusMessage *msg; + +void +dbus_message_set_sender(msg, sender); + DBusMessage *msg; + const char *sender; + +void +dbus_message_set_destination(msg, dest); + DBusMessage *msg; + const char *dest; + +MODULE = Net::DBus::Binding::Message::Signal PACKAGE = Net::DBus::Binding::Message::Signal + +PROTOTYPES: ENABLE + +DBusMessage * +_create(path, interface, name) + char *path; + char *interface; + char *name; + PREINIT: + DBusMessage *msg; + CODE: + msg = dbus_message_new_signal(path, interface, name); + if (!msg) { + croak("No memory to allocate message"); + } + DEBUG_MSG("Create msg new signal %p\n", msg); + DEBUG_MSG(" Type %d\n", dbus_message_get_type(msg)); + DEBUG_MSG(" Interface %s\n", dbus_message_get_interface(msg) ? dbus_message_get_interface(msg) : ""); + DEBUG_MSG(" Path %s\n", dbus_message_get_path(msg) ? dbus_message_get_path(msg) : ""); + DEBUG_MSG(" Member %s\n", dbus_message_get_member(msg) ? dbus_message_get_member(msg) : ""); + RETVAL = msg; + OUTPUT: + RETVAL + +MODULE = Net::DBus::Binding::Message::MethodCall PACKAGE = Net::DBus::Binding::Message::MethodCall + +PROTOTYPES: ENABLE + +DBusMessage * +_create(service, path, interface, method) + char *service; + char *path; + char *interface; + char *method; + PREINIT: + DBusMessage *msg; + CODE: + msg = dbus_message_new_method_call(service, path, interface, method); + if (!msg) { + croak("No memory to allocate message"); + } + DEBUG_MSG("Create msg new method call %p\n", msg); + DEBUG_MSG(" Type %d\n", dbus_message_get_type(msg)); + DEBUG_MSG(" Interface %s\n", dbus_message_get_interface(msg) ? dbus_message_get_interface(msg) : ""); + DEBUG_MSG(" Path %s\n", dbus_message_get_path(msg) ? dbus_message_get_path(msg) : ""); + DEBUG_MSG(" Member %s\n", dbus_message_get_member(msg) ? dbus_message_get_member(msg) : ""); + RETVAL = msg; + OUTPUT: + RETVAL + +MODULE = Net::DBus::Binding::Message::MethodReturn PACKAGE = Net::DBus::Binding::Message::MethodReturn + +PROTOTYPES: ENABLE + +DBusMessage * +_create(call) + DBusMessage *call; + PREINIT: + DBusMessage *msg; + CODE: + msg = dbus_message_new_method_return(call); + if (!msg) { + croak("No memory to allocate message"); + } + dbus_message_set_interface(msg, dbus_message_get_interface(call)); + dbus_message_set_path(msg, dbus_message_get_path(call)); + dbus_message_set_member(msg, dbus_message_get_member(call)); + DEBUG_MSG("Create msg new method return %p\n", msg); + DEBUG_MSG(" Type %d\n", dbus_message_get_type(msg)); + DEBUG_MSG(" Interface %s\n", dbus_message_get_interface(msg) ? dbus_message_get_interface(msg) : ""); + DEBUG_MSG(" Path %s\n", dbus_message_get_path(msg) ? dbus_message_get_path(msg) : ""); + DEBUG_MSG(" Member %s\n", dbus_message_get_member(msg) ? dbus_message_get_member(msg) : ""); + RETVAL = msg; + OUTPUT: + RETVAL + +MODULE = Net::DBus::Binding::Message::Error PACKAGE = Net::DBus::Binding::Message::Error + +PROTOTYPES: ENABLE + +DBusMessage * +_create(replyto, name, message) + DBusMessage *replyto; + char *name; + char *message; + PREINIT: + DBusMessage *msg; + CODE: + msg = dbus_message_new_error(replyto, name, message); + if (!msg) { + croak("No memory to allocate message"); + } + DEBUG_MSG("Create msg new error %p\n", msg); + DEBUG_MSG(" Type %d\n", dbus_message_get_type(msg)); + DEBUG_MSG(" Interface %s\n", dbus_message_get_interface(msg) ? dbus_message_get_interface(msg) : ""); + DEBUG_MSG(" Path %s\n", dbus_message_get_path(msg) ? dbus_message_get_path(msg) : ""); + DEBUG_MSG(" Member %s\n", dbus_message_get_member(msg) ? dbus_message_get_member(msg) : ""); + RETVAL = msg; + OUTPUT: + RETVAL + +MODULE = Net::DBus::Binding::C::PendingCall PACKAGE = Net::DBus::Binding::C::PendingCall + +PROTOTYPES: ENABLE + +DBusMessage * +_steal_reply(call) + DBusPendingCall *call; + PREINIT: + DBusMessage *msg; + CODE: + DEBUG_MSG("Stealing pending call reply %p\n", call); + msg = dbus_pending_call_steal_reply(call); + dbus_message_ref(msg); + DEBUG_MSG("Got reply message %p\n", msg); + RETVAL = msg; + OUTPUT: + RETVAL + +void +dbus_pending_call_block(call) + DBusPendingCall *call; + +dbus_bool_t +dbus_pending_call_get_completed(call) + DBusPendingCall *call; + +void +dbus_pending_call_cancel(call) + DBusPendingCall *call; + +void +_set_notify(call, code) + DBusPendingCall *call; + SV *code; + CODE: + SvREFCNT_inc(code); + DEBUG_MSG("Adding pending call notify %p\n", code); + dbus_pending_call_set_notify(call, _pending_call_callback, code, _pending_call_notify_release); + +void +DESTROY (call) + DBusPendingCall *call; + CODE: + DEBUG_MSG("Unrefing pending call %p", call); + dbus_pending_call_unref(call); + +MODULE = Net::DBus::Binding::C::Watch PACKAGE = Net::DBus::Binding::C::Watch + +int +get_fileno(watch) + DBusWatch *watch; + CODE: + RETVAL = dbus_watch_get_unix_fd(watch); + OUTPUT: + RETVAL + +unsigned int +get_flags(watch) + DBusWatch *watch; + CODE: + RETVAL = dbus_watch_get_flags(watch); + OUTPUT: + RETVAL + +dbus_bool_t +is_enabled(watch) + DBusWatch *watch; + CODE: + RETVAL = dbus_watch_get_enabled(watch); + OUTPUT: + RETVAL + +void +handle(watch, flags) + DBusWatch *watch; + unsigned int flags; + CODE: + DEBUG_MSG("Handling event %d on fd %d (%p)\n", flags, dbus_watch_get_unix_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 = Net::DBus::Binding::C::Timeout PACKAGE = Net::DBus::Binding::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: + DEBUG_MSG("Handling timeout event %p\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 = Net::DBus::Binding::Iterator PACKAGE = Net::DBus::Binding::Iterator + +DBusMessageIter * +_recurse(iter) + DBusMessageIter *iter; + CODE: + RETVAL = dbus_new(DBusMessageIter, 1); + dbus_message_iter_recurse(iter, RETVAL); + OUTPUT: + RETVAL + +DBusMessageIter * +_open_container(iter, type, sig) + DBusMessageIter *iter; + int type; + char *sig; + CODE: + RETVAL = dbus_new(DBusMessageIter, 1); + if (!dbus_message_iter_open_container(iter, type, sig && *sig == '\0' ? NULL : sig, RETVAL)) { + dbus_free(RETVAL); + croak("failed to open iterator container"); + } + OUTPUT: + RETVAL + +void +_close_container(iter, sub_iter) + DBusMessageIter *iter; + DBusMessageIter *sub_iter; + CODE: + dbus_message_iter_close_container(iter, sub_iter); + +int +get_arg_type(iter) + DBusMessageIter *iter; + CODE: + RETVAL = dbus_message_iter_get_arg_type(iter); + OUTPUT: + RETVAL + +int +get_element_type(iter) + DBusMessageIter *iter; + CODE: + RETVAL = dbus_message_iter_get_element_type(iter); + OUTPUT: + RETVAL + +dbus_bool_t +has_next(iter) + DBusMessageIter *iter; + CODE: + RETVAL = dbus_message_iter_has_next(iter); + OUTPUT: + RETVAL + +dbus_bool_t +next(iter) + DBusMessageIter *iter; + CODE: + RETVAL = dbus_message_iter_next(iter); + OUTPUT: + RETVAL + +dbus_bool_t +get_boolean(iter) + DBusMessageIter *iter; + CODE: + dbus_message_iter_get_basic(iter, &RETVAL); + OUTPUT: + RETVAL + +unsigned char +get_byte(iter) + DBusMessageIter *iter; + CODE: + dbus_message_iter_get_basic(iter, &RETVAL); + OUTPUT: + RETVAL + +dbus_int16_t +get_int16(iter) + DBusMessageIter *iter; + CODE: + dbus_message_iter_get_basic(iter, &RETVAL); + OUTPUT: + RETVAL + +dbus_uint16_t +get_uint16(iter) + DBusMessageIter *iter; + CODE: + dbus_message_iter_get_basic(iter, &RETVAL); + OUTPUT: + RETVAL + +dbus_int32_t +get_int32(iter) + DBusMessageIter *iter; + CODE: + dbus_message_iter_get_basic(iter, &RETVAL); + OUTPUT: + RETVAL + +dbus_uint32_t +get_uint32(iter) + DBusMessageIter *iter; + CODE: + dbus_message_iter_get_basic(iter, &RETVAL); + OUTPUT: + RETVAL + +dbus_int64_t +_get_int64(iter) + DBusMessageIter *iter; + CODE: + dbus_message_iter_get_basic(iter, &RETVAL); + OUTPUT: + RETVAL + +dbus_uint64_t +_get_uint64(iter) + DBusMessageIter *iter; + CODE: + dbus_message_iter_get_basic(iter, &RETVAL); + OUTPUT: + RETVAL + +double +get_double(iter) + DBusMessageIter *iter; + CODE: + dbus_message_iter_get_basic(iter, &RETVAL); + OUTPUT: + RETVAL + +char * +get_string(iter) + DBusMessageIter *iter; + CODE: + dbus_message_iter_get_basic(iter, &RETVAL); + OUTPUT: + RETVAL + +char * +get_signature(iter) + DBusMessageIter *iter; + CODE: + dbus_message_iter_get_basic(iter, &RETVAL); + OUTPUT: + RETVAL + +char * +get_object_path(iter) + DBusMessageIter *iter; + CODE: + dbus_message_iter_get_basic(iter, &RETVAL); + OUTPUT: + RETVAL + + +void +append_boolean(iter, val) + DBusMessageIter *iter; + dbus_bool_t val; + CODE: + if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_BOOLEAN, &val)) { + croak("cannot append boolean"); + } + +void +append_byte(iter, val) + DBusMessageIter *iter; + unsigned char val; + CODE: + if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_BYTE, &val)) { + croak("cannot append byte"); + } + +void +append_int16(iter, val) + DBusMessageIter *iter; + dbus_int16_t val; + CODE: + if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_INT16, &val)) { + croak("cannot append int16"); + } + +void +append_uint16(iter, val) + DBusMessageIter *iter; + dbus_uint16_t val; + CODE: + if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_UINT16, &val)) { + croak("cannot append uint16"); + } + +void +append_int32(iter, val) + DBusMessageIter *iter; + dbus_int32_t val; + CODE: + if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_INT32, &val)) { + croak("cannot append int32"); + } + +void +append_uint32(iter, val) + DBusMessageIter *iter; + dbus_uint32_t val; + CODE: + if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_UINT32, &val)) { + croak("cannot append uint32"); + } + +void +_append_int64(iter, val) + DBusMessageIter *iter; + dbus_int64_t val; + CODE: + if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_INT64, &val)) { + croak("cannot append int64"); + } + +void +_append_uint64(iter, val) + DBusMessageIter *iter; + dbus_uint64_t val; + CODE: + if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_UINT64, &val)) { + croak("cannot append uint64"); + } + +void +append_double(iter, val) + DBusMessageIter *iter; + double val; + CODE: + if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_DOUBLE, &val)) { + croak("cannot append double"); + } + +void +append_string(iter, val) + DBusMessageIter *iter; + char *val; + CODE: + if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_STRING, &val)) { + croak("cannot append string"); + } + +void +append_object_path(iter, val) + DBusMessageIter *iter; + char *val; + CODE: + if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_OBJECT_PATH, &val)) { + croak("cannot append object path"); + } + +void +append_signature(iter, val) + DBusMessageIter *iter; + char *val; + CODE: + if (!dbus_message_iter_append_basic(iter, DBUS_TYPE_SIGNATURE, &val)) { + croak("cannot append signature"); + } + + + +void +DESTROY(iter) + DBusMessageIter *iter; + CODE: + DEBUG_MSG("Destroying iterator %p\n", iter); + dbus_free(iter); + +MODULE = Net::DBus PACKAGE = Net::DBus diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..6b66d36 --- /dev/null +++ b/LICENSE @@ -0,0 +1,438 @@ +Net-DBus may be redistributed and/or modified under the terms of Perl itself. +Either: + +a) the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any + later version + +or + +b) the "Artistic License" + +--------------------------------------------------------------------------- + + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + +--------------------------------------------------------------------------- + +The "Artistic License" + + Preamble + + The intent of this document is to state the conditions under which a + Package may be copied, such that the Copyright Holder maintains some + semblance of artistic control over the development of the package, + while giving the users of the package the right to use and distribute + the Package in a more-or-less customary fashion, plus the right to make + reasonable modifications. + + Definitions + + "Package" + refers to the collection of files distributed by the Copyright + Holder, and derivatives of that collection of files created through + textual modification. + + "Standard Version" + refers to such a Package if it has not been modified, or has been + modified in accordance with the wishes of the Copyright Holder as + specified below. + + "Copyright Holder" + is whoever is named in the copyright or copyrights for the package. + + "You" + is you, if you're thinking about copying or distributing this Pack- + age. + + "Reasonable copying fee" + is whatever you can justify on the basis of media cost, duplication + charges, time of people involved, and so on. (You will not be + required to justify it to the Copyright Holder, but only to the + computing community at large as a market that must bear the fee.) + + "Freely Available" + means that no fee is charged for the item itself, though there may + be fees involved in handling the item. It also means that recipi- + ents of the item may redistribute it under the same conditions they + received it. + + Conditions + + 1. You may make and give away verbatim copies of the source form of + the Standard Version of this Package without restriction, provided + that you duplicate all of the original copyright notices and asso- + ciated disclaimers. + + 2. You may apply bug fixes, portability fixes and other modifications + derived from the Public Domain or from the Copyright Holder. A + Package modified in such a way shall still be considered the Stan- + dard Version. + + 3. You may otherwise modify your copy of this Package in any way, pro- + vided that you insert a prominent notice in each changed file stat- + ing how and when you changed that file, and provided that you do at + least ONE of the following: + + a) place your modifications in the Public Domain or otherwise make + them Freely Available, such as by posting said modifications to + Usenet or an equivalent medium, or placing the modifications on + a major archive site such as uunet.uu.net, or by allowing the + Copyright Holder to include your modifications in the Standard + Version of the Package. + + b) use the modified Package only within your corporation or orga- + nization. + + c) rename any non-standard executables so the names do not con- + flict with standard executables, which must also be provided, + and provide a separate manual page for each non-standard exe- + cutable that clearly documents how it differs from the Standard + Version. + + d) make other distribution arrangements with the Copyright Holder. + + 4. You may distribute the programs of this Package in object code or + executable form, provided that you do at least ONE of the follow- + ing: + + a) distribute a Standard Version of the executables and library + files, together with instructions (in the manual page or equiv- + alent) on where to get the Standard Version. + + b) accompany the distribution with the machine-readable source of + the Package with your modifications. + + c) give non-standard executables non-standard names, and clearly + document the differences in manual pages (or equivalent), + together with instructions on where to get the Standard Ver- + sion. + + d) make other distribution arrangements with the Copyright Holder. + + 5. You may charge a reasonable copying fee for any distribution of + this Package. You may charge any fee you choose for support of + this Package. You may not charge a fee for this Package itself. + However, you may distribute this Package in aggregate with other + (possibly commercial) programs as part of a larger (possibly com- + mercial) software distribution provided that you do not advertise + this Package as a product of your own. You may embed this Pack- + age's interpreter within an executable of yours (by linking); this + shall be construed as a mere form of aggregation, provided that the + complete Standard Version of the interpreter is so embedded. + + 6. The scripts and library files supplied as input to or produced as + output from the programs of this Package do not automatically fall + under the copyright of this Package, but belong to whoever gener- + ated them, and may be sold commercially, and may be aggregated with + this Package. If such scripts or library files are aggregated with + this Package via the so-called "undump" or "unexec" methods of pro- + ducing a binary executable image, then distribution of such an + image shall neither be construed as a distribution of this Package + nor shall it fall under the restrictions of Paragraphs 3 and 4, + provided that you do not represent such an executable image as a + Standard Version of this Package. + + 7. C subroutines (or comparably compiled subroutines in other lan- + guages) supplied by you and linked into this Package in order to + emulate subroutines and variables of the language defined by this + Package shall not be considered part of this Package, but are the + equivalent of input as in Paragraph 6, provided these subroutines + do not change the language in any way that would cause it to fail + the regression tests for the language. + + 8. Aggregation of this Package with a commercial distribution is + always permitted provided that the use of this Package is embedded; + that is, when no overt attempt is made to make this Package's + interfaces visible to the end user of the commercial distribution. + Such use shall not be construed as a distribution of this Package. + + 9. The name of the Copyright Holder may not be used to endorse or pro- + mote products derived from this software without specific prior + written permission. + + 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED + WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES + OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + + The End diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..ca2f41a --- /dev/null +++ b/MANIFEST @@ -0,0 +1,78 @@ +AUTHORS +autobuild.sh +CHANGES +DBus.xs +examples/dump-object-xml.pl +examples/dump-object.pl +examples/example-client-async.pl +examples/example-client-no-introspect.pl +examples/example-client.pl +examples/example-service-async.pl +examples/example-service-magic.pl +examples/example-service-no-introspect.pl +examples/example-service.pl +examples/example-signal-emitter.pl +examples/example-signal-receiver.pl +examples/lshal.pl +examples/notification.pl +examples/strict-exports.pl +lib/Net/DBus.pm +lib/Net/DBus/Annotation.pm +lib/Net/DBus/ASyncReply.pm +lib/Net/DBus/Binding/Bus.pm +lib/Net/DBus/Binding/Connection.pm +lib/Net/DBus/Binding/Introspector.pm +lib/Net/DBus/Binding/Iterator.pm +lib/Net/DBus/Binding/Message.pm +lib/Net/DBus/Binding/Message/Error.pm +lib/Net/DBus/Binding/Message/MethodCall.pm +lib/Net/DBus/Binding/Message/MethodReturn.pm +lib/Net/DBus/Binding/Message/Signal.pm +lib/Net/DBus/Binding/PendingCall.pm +lib/Net/DBus/Binding/Server.pm +lib/Net/DBus/Binding/Value.pm +lib/Net/DBus/Binding/Watch.pm +lib/Net/DBus/Callback.pm +lib/Net/DBus/Dumper.pm +lib/Net/DBus/Error.pm +lib/Net/DBus/Exporter.pm +lib/Net/DBus/Object.pm +lib/Net/DBus/Reactor.pm +lib/Net/DBus/RemoteObject.pm +lib/Net/DBus/RemoteService.pm +lib/Net/DBus/Service.pm +lib/Net/DBus/Test/MockConnection.pm +lib/Net/DBus/Test/MockIterator.pm +lib/Net/DBus/Test/MockMessage.pm +lib/Net/DBus/Test/MockObject.pm +lib/Net/DBus/Tutorial.pod +lib/Net/DBus/Tutorial/ExportingObjects.pod +lib/Net/DBus/Tutorial/UsingObjects.pod +LICENSE +Makefile.PL +MANIFEST This list of files +MANIFEST.SKIP +META.yml +META.yml.PL +Net-DBus.spec +Net-DBus.spec.PL +README +t/00-constants.t +t/05-pod.t +t/10-pod-coverage.t +t/15-message.t +t/20-callback.t +t/25-reactor.t +t/30-server.t +t/40-introspector.t +t/42-object-introspect-avahi.t +t/45-exporter.t +t/50-object-introspect.t +t/55-method-calls.t +t/56-scalar-param-typing.t +t/60-object-props.t +t/65-object-magic.t +t/66-child-objects.t +t/70-errors.t +t/75-notifications.t +typemap diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..9c62faa --- /dev/null +++ b/MANIFEST.SKIP @@ -0,0 +1,17 @@ +pm_to_blib +DBus\.o +DBus\.c +DBus\.bs +.*.old +DBus- +blib +.*\.bak +CVS +.cvsignore +.*~ +.#.* +#.* +.hg +^Makefile$ +^cover_db/ +Net-DBus-.*.tar.gz diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..28e9dc2 --- /dev/null +++ b/META.yml @@ -0,0 +1,27 @@ +--- #YAML:1.0 +name: Net-DBus +abstract: Extension for the DBus bindings +version: 1.0.0 +author: + - Daniel P. Berrange +license: gpl +generated_by: ExtUtils::MakeMaker version 6.30 +requires: + Time::HiRes: 0 + XML::Twig: 0 +build_requires: + Test::More: 0 + Test::Pod: 0 + Test::Pod::Coverage: 0 + +resources: + license: http://www.gnu.org/licenses/gpl.html + homepage: http://www.freedesktop.org/wiki/Software/dbus + repository: http://hg.berrange.com/libraries/net-dbus--devel + MailingList: http://lists.freedesktop.org/mailman/listinfo/dbus/ + +distribution_type: module + +meta-spec: + version: 1.3 + url: http://module-build.sourceforge.net/META-spec-v1.3.html diff --git a/META.yml.PL b/META.yml.PL new file mode 100644 index 0000000..9016a0a --- /dev/null +++ b/META.yml.PL @@ -0,0 +1,53 @@ +# Copyright (C) 2008 Daniel Berrange + +use strict; +use warnings; + +die unless (scalar @ARGV == 1); + +open SRC, "lib/Net/DBus.pm" + or die "lib/Net/DBus.pm: $!"; + +our $VERSION; +while () { + if (/\$VERSION\s*=\s*'(.*)'/) { + $VERSION=$1; + } +} +close SRC; + +local $/ = undef; +$_ = ; +s/\@VERSION\@/$VERSION/g; + +open SPEC, ">$ARGV[0]" or die "$!"; +print SPEC $_; +close SPEC; +__DATA__ +--- #YAML:1.0 +name: Net-DBus +abstract: Extension for the DBus bindings +version: @VERSION@ +author: + - Daniel P. Berrange +license: gpl +generated_by: ExtUtils::MakeMaker version 6.30 +requires: + Time::HiRes: 0 + XML::Twig: 0 +build_requires: + Test::More: 0 + Test::Pod: 0 + Test::Pod::Coverage: 0 + +resources: + license: http://www.gnu.org/licenses/gpl.html + homepage: http://www.freedesktop.org/wiki/Software/dbus + repository: http://hg.berrange.com/libraries/net-dbus--devel + MailingList: http://lists.freedesktop.org/mailman/listinfo/dbus/ + +distribution_type: module + +meta-spec: + version: 1.3 + url: http://module-build.sourceforge.net/META-spec-v1.3.html diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..2973a69 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,51 @@ +use 5.006; +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. + +my $DBUS_LIBS = `pkg-config --libs dbus-1`; +my $DBUS_CFLAGS = `pkg-config --cflags dbus-1`; + +if (!defined $DBUS_LIBS || !defined DBUS_CFLAGS) { + die "could not run 'pkg-config' to determine compiler/linker flags for dbus library: $!\n"; +} +if (!$DBUS_LIBS || !$DBUS_CFLAGS) { + die "'pkg-config' didn't report any compiler/linker flags for dbus library\n"; +} + +my $wall = ""; +if ($^O eq "linux") { + $wall = "-Wall"; +} + +WriteMakefile( + 'NAME' => 'Net::DBus', + 'VERSION_FROM' => 'lib/Net/DBus.pm', + 'PREREQ_PM' => { + 'Test::More' => 0, + 'Time::HiRes' => 0, + 'XML::Twig' => 0, + }, + 'AUTHOR' => 'Daniel Berrange ', + 'LIBS' => [$DBUS_LIBS], + 'DEFINE' => ("-DNET_DBUS_DEBUG=1"), + 'INC' => "$wall $DBUS_CFLAGS", + 'NO_META' => 1, + 'depend' => { + Net-DBus.spec => '$(VERSION_FROM)', + Makefile => '$(VERSION_FROM)', + }, + 'realclean' => { + FILES => 'Net-DBus.spec', + }, +); + +package MY; + +sub libscan + { + my ($self, $path) = @_; + ($path =~ /\~$/ || $path =~ m,/CVS/,) ? undef : $path; + } + +__END__ diff --git a/Net-DBus.spec b/Net-DBus.spec new file mode 100644 index 0000000..76f7e4b --- /dev/null +++ b/Net-DBus.spec @@ -0,0 +1,64 @@ +# Automatically generated by DBus.spec.PL + +%define appname Net-DBus + +%define _extra_release %{?extra_release:%{extra_release}} + +Summary: Perl API to the DBus message system +Name: perl-%{appname} +Version: 1.0.0 +Release: 1%{_extra_release} +License: GPLv2+ or Artistic +Group: Development/Libraries +URL: http://search.cpan.org/dist/%{appname} +Source0: http://www.cpan.org/modules/by-module/Net/%{appname}-%{version}.tar.gz +BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n) +Requires: perl(:MODULE_COMPAT_%(eval "`%{__perl} -V:version`"; echo $version)) +Requires: dbus >= 1.0.0 +BuildRequires: dbus-devel > 1.0.0 +BuildRequires: perl(XML::Twig) +BuildRequires: perl(Time::HiRes) +BuildRequires: perl(Test::More) +BuildRequires: perl(Test::Pod) +BuildRequires: perl(Test::Pod::Coverage) + +%description +Provides a Perl API to the DBus message system + +%prep +%setup -q -n %{appname}-%{version} + + +%build +if [ -z "$DBUS_HOME" ]; then + %{__perl} Makefile.PL INSTALLDIRS=vendor +else + %{__perl} Makefile.PL INSTALLDIRS=vendor DBUS_HOME=$DBUS_HOME +fi +make %{?_smp_mflags} + +%install +rm -rf $RPM_BUILD_ROOT + +make pure_install PERL_INSTALL_ROOT=$RPM_BUILD_ROOT + +find $RPM_BUILD_ROOT -name perllocal.pod -exec rm -f {} \; +find $RPM_BUILD_ROOT -name .packlist -exec rm -f {} \; + +%{_fixperms} $RPM_BUILD_ROOT/* + +%check +make test + +%clean +rm -rf $RPM_BUILD_ROOT + +%files +%defattr(-,root,root) +%doc README CHANGES AUTHORS LICENSE examples/*.pl +%{_mandir}/man3/* +%{perl_vendorarch}/Net/DBus.pm +%{perl_vendorarch}/Net/DBus/ +%{perl_vendorarch}/auto/Net/DBus + +%changelog diff --git a/Net-DBus.spec.PL b/Net-DBus.spec.PL new file mode 100644 index 0000000..40350df --- /dev/null +++ b/Net-DBus.spec.PL @@ -0,0 +1,92 @@ +# -*- rpm-spec -*- +# Copyright (C) 2004-2006 Daniel Berrange +# +# $Id: Net-DBus.spec.PL,v 1.8 2006/01/06 16:21:04 dan Exp $ + +use strict; + +die unless (scalar @ARGV == 1); + +open SRC, "lib/Net/DBus.pm" + or die "lib/Net/DBus.pm: $!"; + +our $VERSION; +while () { + if (/\$VERSION\s*=\s*'(.*)'/) { + $VERSION=$1; + } +} +close SRC; + +local $/ = undef; +$_ = ; +s/\@VERSION\@/$VERSION/g; + +open SPEC, ">$ARGV[0]" or die "$!"; +print SPEC $_; +close SPEC; +__DATA__ +# Automatically generated by DBus.spec.PL + +%define appname Net-DBus + +%define _extra_release %{?extra_release:%{extra_release}} + +Summary: Perl API to the DBus message system +Name: perl-%{appname} +Version: @VERSION@ +Release: 1%{_extra_release} +License: GPLv2+ or Artistic +Group: Development/Libraries +URL: http://search.cpan.org/dist/%{appname} +Source0: http://www.cpan.org/modules/by-module/Net/%{appname}-%{version}.tar.gz +BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n) +Requires: perl(:MODULE_COMPAT_%(eval "`%{__perl} -V:version`"; echo $version)) +Requires: dbus >= 1.0.0 +BuildRequires: dbus-devel > 1.0.0 +BuildRequires: perl(XML::Twig) +BuildRequires: perl(Time::HiRes) +BuildRequires: perl(Test::More) +BuildRequires: perl(Test::Pod) +BuildRequires: perl(Test::Pod::Coverage) + +%description +Provides a Perl API to the DBus message system + +%prep +%setup -q -n %{appname}-%{version} + + +%build +if [ -z "$DBUS_HOME" ]; then + %{__perl} Makefile.PL INSTALLDIRS=vendor +else + %{__perl} Makefile.PL INSTALLDIRS=vendor DBUS_HOME=$DBUS_HOME +fi +make %{?_smp_mflags} + +%install +rm -rf $RPM_BUILD_ROOT + +make pure_install PERL_INSTALL_ROOT=$RPM_BUILD_ROOT + +find $RPM_BUILD_ROOT -name perllocal.pod -exec rm -f {} \; +find $RPM_BUILD_ROOT -name .packlist -exec rm -f {} \; + +%{_fixperms} $RPM_BUILD_ROOT/* + +%check +make test + +%clean +rm -rf $RPM_BUILD_ROOT + +%files +%defattr(-,root,root) +%doc README CHANGES AUTHORS LICENSE examples/*.pl +%{_mandir}/man3/* +%{perl_vendorarch}/Net/DBus.pm +%{perl_vendorarch}/Net/DBus/ +%{perl_vendorarch}/auto/Net/DBus + +%changelog diff --git a/README b/README new file mode 100644 index 0000000..22bde1e --- /dev/null +++ b/README @@ -0,0 +1,131 @@ + Net::DBus + ========= + +Net::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: + + http://www.freedesktop.org/software/dbus/ + +This version operates against DBus 1.00, and later + +INSTALLATION +------------ + +To install this module type the following: + + perl Makefile.PL + make + make test + sudo make install + +The makefile calls the C script to determine the +correct flags to pass to the compiler & linkers when building +the XS part of the module. Thus, ensure pkg-config is in +a directory listed by the $PATH environment. + +The pkg-config program will likely find the DBus install in /usr +provided by the base OS distribution, so if testing against an +alternate install of DBus, set the C$PKG_CONFIG_PATH env +variable before generating the Makefile. For example, if your +dbus installation is in C<$HOME/usr/dbus-cvs-tip> , then to build +and install against this version of DBus do + + export PKG_CONFIG_PATH=$HOME/usr/dbus-cvs-tip/lib/pkg-config + perl Makefile.PL PREFIX=$HOME/usr/dbus-cvs-tip + make + make test + make install + + +DEPENDENCIES +------------ + +In keeping with the C API, the Perl DBus implementation +has minimal external dependancies: + + Time::HiRes + XML::Twig + XML::Parser + +And to run the test suite: + + Test::More + Test::Pod (optional, but recommended) + Test::Pod::Coverage (optional, but recommended) + +Although they are not part of the base Perl distribution, most +OS distributor will already provide addon packages containing +these modules. Failing this, they are all available from CPAN +http://search.cpan.org/ + +EXAMPLES +-------- + +There are a number of example programs in the examples/ +subdirectory demonstrating use of the high level application +developer APIs. + + example-service.pl - Providing a simple service + example-client.pl - Talking to a remote service + example-signal-emitter.pl - How to broadcast signals + example-signal-receiver.pl - How to receive signals + dump-object.pl - Dump info about dbus objects + lshal.pl - Dump names of all HAL devices + +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-1.0.0 DBus-1.0.0-new + + * Extract a pristine copy of the source: + + gunzip -c DBus-1.0.0.tar.gz | tar xf - + mv DBus-1.0.0 DBus-1.0.0-orig + + * Generate the patch: + + diff -ruN DBus-1.0.0-orig DBus-1.0.0-new \ + > DBus-1.0.0-[something].patch + gzip DBus-1.0.0-[something].patch + + +Send the resulting to .patch.gz file directly to +Daniel Berrange + +COPYRIGHT AND LICENCE +--------------------- + +Copyright (C) 2004-2011 Daniel Berrange + +Net-DBus may be redistributed and/or modified under the terms of Perl itself. +Either: + +a) the GNU General Public License as published by the Free + Software Foundation; either version 2, or (at your option) any + later version + +or + +b) the "Artistic License" + + +See the file "COPYING" for the full text of each license + +-- End + diff --git a/autobuild.sh b/autobuild.sh new file mode 100755 index 0000000..066a282 --- /dev/null +++ b/autobuild.sh @@ -0,0 +1,53 @@ +#!/bin/sh +# +# This script is used to Test::AutoBuild (http://www.autobuild.org) +# to perform automated builds of the DBus module + +NAME=Net-DBus + +set -e + +make -k realclean ||: +rm -rf MANIFEST blib pm_to_blib + +perl Makefile.PL PREFIX=$AUTOBUILD_INSTALL_ROOT + +# Build the RPM. +make +make manifest + +if [ -z "$USE_COVER" ]; then + perl -MDevel::Cover -e '' 1>/dev/null 2>&1 && USE_COVER=1 || USE_COVER=0 +fi + +if [ -z "$SKIP_TESTS" -o "$SKIP_TESTS" = "0" ]; then + if [ "$USE_COVER" = "1" ]; then + cover -delete + HARNESS_PERL_SWITCHES=-MDevel::Cover make test + cover + mkdir blib/coverage + cp -a cover_db/*.html cover_db/*.css blib/coverage + mv blib/coverage/coverage.html blib/coverage/index.html + else + make test + fi +fi + +make install + +rm -f $NAME-*.tar.gz +make dist + +if [ -f /usr/bin/rpmbuild ]; then + if [ -n "$AUTOBUILD_COUNTER" ]; then + EXTRA_RELEASE=".auto$AUTOBUILD_COUNTER" + else + NOW=`date +"%s"` + EXTRA_RELEASE=".$USER$NOW" + fi + # The --nodeps bit is a nasty hack to force build + # against the dbus from autobuild, rather than a + # (non-existant) installed RPM + rpmbuild -ta --define "extra_release $EXTRA_RELEASE" --clean $NAME-*.tar.gz --nodeps +fi + diff --git a/examples/dump-object-xml.pl b/examples/dump-object-xml.pl new file mode 100644 index 0000000..1768052 --- /dev/null +++ b/examples/dump-object-xml.pl @@ -0,0 +1,23 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +use Net::DBus; +use Net::DBus::Dumper; +use Carp qw(confess); + +$SIG{__DIE__} = sub {confess $_[0] }; + +my $bus = Net::DBus->find; + +if (int(@ARGV) != 2) { + die "syntax: $0 SERVICE OBJECT"; +} + +my $service = $bus->get_service(shift @ARGV); +my $object = $service->get_object(shift @ARGV); +my $xml = $object->_introspector->format(); +print $xml, "\n"; + + diff --git a/examples/dump-object.pl b/examples/dump-object.pl new file mode 100644 index 0000000..4ce4a7b --- /dev/null +++ b/examples/dump-object.pl @@ -0,0 +1,26 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +use Net::DBus; +use Net::DBus::Dumper; +use Carp qw(confess); + +$SIG{__DIE__} = sub {confess $_[0] }; + +my $bus = Net::DBus->find; + +if (@ARGV) { + my $service = $bus->get_service(shift @ARGV); + + if (@ARGV) { + my $object = $service->get_object(shift @ARGV); + print dbus_dump($object); + } else { + print dbus_dump($service); + } +} else { + print dbus_dump($bus); +} + diff --git a/examples/example-client-async.pl b/examples/example-client-async.pl new file mode 100644 index 0000000..deba421 --- /dev/null +++ b/examples/example-client-async.pl @@ -0,0 +1,40 @@ +#/usr/bin/perl + +use warnings; +use strict; + +use Net::DBus; +use Net::DBus::Reactor; +use Net::DBus::Annotation qw(:call); + +my $bus = Net::DBus->session(); + +my $service = $bus->get_service("org.designfu.SampleService"); +my $object = $service->get_object("/SomeObject"); + +print "Doing async call\n"; +my $reply = $object->HelloWorld(dbus_call_async, "Hello from example-client.pl!"); + +my $r = Net::DBus::Reactor->main; + +sub all_done { + my $reply = shift; + my $list = $reply->get_result; + print "[", join(", ", map { "'$_'" } @{$list}), "]\n"; + + $r->shutdown; +} + +print "Setting notify\n"; +$reply->set_notify(\&all_done); + +sub tick { + print "Tick-tock\n"; +} + + +print "Adding timer\n"; +$r->add_timeout(500, \&tick); + +print "Entering main loop\n"; +$r->run; diff --git a/examples/example-client-no-introspect.pl b/examples/example-client-no-introspect.pl new file mode 100644 index 0000000..01be26a --- /dev/null +++ b/examples/example-client-no-introspect.pl @@ -0,0 +1,26 @@ +#/usr/bin/perl + +use warnings; +use strict; + +use Net::DBus; +use Carp qw(cluck carp); +#$SIG{__WARN__} = sub { cluck $_[0] }; +#$SIG{__DIE__} = sub { carp $_[0] }; + +my $bus = Net::DBus->session(); + +my $service = $bus->get_service("org.designfu.SampleService"); +my $object = $service->get_object("/SomeObject", "org.designfu.SampleInterface"); + +my $list = $object->HelloWorld("Hello from example-client.pl!"); + +print "[", join(", ", map { "'$_'" } @{$list}), "]\n"; + +my $tuple = $object->GetTuple(); + +print "(", join(", ", map { "'$_'" } @{$tuple}), ")\n"; + +my $dict = $object->GetDict(); + +print "{", join(", ", map { "'$_': '" . $dict->{$_} . "'"} keys %{$dict}), "}\n"; diff --git a/examples/example-client.pl b/examples/example-client.pl new file mode 100644 index 0000000..74ba76e --- /dev/null +++ b/examples/example-client.pl @@ -0,0 +1,35 @@ +#/usr/bin/perl + +use warnings; +use strict; + +use Net::DBus; +use Carp qw(cluck carp confess); +#$SIG{__WARN__} = sub { cluck $_[0] }; +#$SIG{__DIE__} = sub { confess "[". $_[0] ."]"}; + +my $bus = Net::DBus->session(); + +my $service = $bus->get_service("org.designfu.SampleService"); +my $object = $service->get_object("/SomeObject"); + +my $list = $object->HelloWorld("Hello from example-client.pl!"); + +print "[", join(", ", map { "'$_'" } @{$list}), "]\n"; + +my $tuple = $object->GetTuple(); + +print "(", join(", ", map { "'$_'" } @{$tuple}), ")\n"; + +my $dict = $object->GetDict(); + +print "{", join(", ", map { "'$_': '" . $dict->{$_} . "'"} keys %{$dict}), "}\n"; + +if (0) { + $object->name("John Doe"); + $object->age(21); +#$object->email('john.doe@example.com'); + + print $object->name, " ", " ", $object->email, "\n"; + +} diff --git a/examples/example-service-async.pl b/examples/example-service-async.pl new file mode 100644 index 0000000..d4b2f9f --- /dev/null +++ b/examples/example-service-async.pl @@ -0,0 +1,60 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +use Carp qw(confess cluck); +use Net::DBus; +use Net::DBus::Service; +use Net::DBus::Reactor; + +#... continued at botom + + +package SomeObject; + +use base qw(Net::DBus::Object); +use Net::DBus::Exporter qw(org.designfu.SampleInterface); + +sub new { + my $class = shift; + my $service = shift; + my $self = $class->SUPER::new($service, "/SomeObject"); + bless $self, $class; + + return $self; +} + +dbus_method("HelloWorld", ["string"], [["array", "string"]]); +sub HelloWorld { + my $self = shift; + my $message = shift; + print "Do hello world\n"; + print $message, "\n"; + sleep 10; + return ["Hello", " from example-service-async.pl"]; +} + +dbus_method("GetDict", [], [["dict", "string", "string"]]); +sub GetDict { + my $self = shift; + print "Do get dict\n"; + sleep 10; + return {"first" => "Hello Dict", "second" => " from example-service.pl"}; +} + +dbus_method("GetTuple", [], [["struct", "string", "string"]]); +sub GetTuple { + my $self = shift; + print "Do get tuple\n"; + sleep 10; + return ["Hello Tuple", " from example-service.pl"]; +} + +package main; + +my $bus = Net::DBus->session(); +my $service = $bus->export_service("org.designfu.SampleService"); +my $object = SomeObject->new($service); + +Net::DBus::Reactor->main->run(); diff --git a/examples/example-service-magic.pl b/examples/example-service-magic.pl new file mode 100644 index 0000000..c313a75 --- /dev/null +++ b/examples/example-service-magic.pl @@ -0,0 +1,66 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +use Carp qw(confess cluck); +use Net::DBus; +use Net::DBus::Service; +use Net::DBus::Reactor; + +#... continued at botom + + +package SomeObject; + +use base qw(Net::DBus::Object); +use Net::DBus::Exporter qw(org.designfu.SampleInterface); + +#use Class::MethodMaker [ scalar => [ qw(name email age) ]]; + +#dbus_property("name", "string"); +#dbus_property("email", "string", "read"); +#dbus_property("age", "int32", "write"); + +sub new { + my $class = shift; + my $service = shift; + my $self = $class->SUPER::new($service, "/SomeObject"); + bless $self, $class; + + return $self; +} + +dbus_method("HelloWorld", ["string", "caller"], [["array", "string"]]); +sub HelloWorld { + my $self = shift; + my $message = shift; + my $caller = shift; + print "Do hello world from $caller\n"; + print $message, "\n"; + return ["Hello", " from example-service.pl"]; +} + +dbus_method("GetDict", ["caller"], [["dict", "string", "string"]]); +sub GetDict { + my $self = shift; + my $caller = shift; + print "Do get dict from $caller\n"; + return {"first" => "Hello Dict", "second" => " from example-service.pl"}; +} + +dbus_method("GetTuple", ["caller"], [["struct", "string", "string"]]); +sub GetTuple { + my $self = shift; + my $caller = shift; + print "Do get tuple from $caller\n"; + return ["Hello Tuple", " from example-service.pl"]; +} + +package main; + +my $bus = Net::DBus->session(); +my $service = $bus->export_service("org.designfu.SampleService"); +my $object = SomeObject->new($service); + +Net::DBus::Reactor->main->run(); diff --git a/examples/example-service-no-introspect.pl b/examples/example-service-no-introspect.pl new file mode 100644 index 0000000..f5ab365 --- /dev/null +++ b/examples/example-service-no-introspect.pl @@ -0,0 +1,53 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +use Carp qw(confess cluck); +use Net::DBus; +use Net::DBus::Service; +use Net::DBus::Reactor; + +#... continued at botom + + +package SomeObject; + +use base qw(Net::DBus::Object); + +sub new { + my $class = shift; + my $service = shift; + my $self = $class->SUPER::new($service, "/SomeObject"); + bless $self, $class; + + return $self; +} + +sub HelloWorld { + my $self = shift; + my $message = shift; + print "Do hello world\n"; + print $message, "\n"; + return ["Hello", " from example-service.pl"]; +} + +sub GetDict { + my $self = shift; + print "Do get dict\n"; + return {"first" => "Hello Dict", "second" => " from example-service.py"}; +} + +sub GetTuple { + my $self = shift; + print "Do get tuple\n"; + return ["Hello Tuple", " from example-service.py"]; +} + +package main; + +my $bus = Net::DBus->session(); +my $service = $bus->export_service("org.designfu.SampleService"); +my $object = SomeObject->new($service); + +Net::DBus::Reactor->main->run(); diff --git a/examples/example-service.pl b/examples/example-service.pl new file mode 100644 index 0000000..0343521 --- /dev/null +++ b/examples/example-service.pl @@ -0,0 +1,63 @@ +#!/usr/bin/perl + +use warnings; +use strict; + +use Carp qw(confess cluck); +use Net::DBus; +use Net::DBus::Service; +use Net::DBus::Reactor; + +#... continued at botom + + +package SomeObject; + +use base qw(Net::DBus::Object); +use Net::DBus::Exporter qw(org.designfu.SampleInterface); + +#use Class::MethodMaker [ scalar => [ qw(name email age) ]]; + +#dbus_property("name", "string"); +#dbus_property("email", "string", "read"); +#dbus_property("age", "int32", "write"); + +sub new { + my $class = shift; + my $service = shift; + my $self = $class->SUPER::new($service, "/SomeObject"); + bless $self, $class; + + return $self; +} + +dbus_method("HelloWorld", ["string"], [["array", "string"]], { param_names => ["message"], return_names => ["reply"] }); +sub HelloWorld { + my $self = shift; + my $message = shift; + print "Do hello world\n"; + print $message, "\n"; + return ["Hello", " from example-service.pl"]; +} + +dbus_method("GetDict", [], [["dict", "string", "string"]]); +sub GetDict { + my $self = shift; + print "Do get dict\n"; + return {"first" => "Hello Dict", "second" => " from example-service.pl"}; +} + +dbus_method("GetTuple", [], [["struct", "string", "string"]]); +sub GetTuple { + my $self = shift; + print "Do get tuple\n"; + return ["Hello Tuple", " from example-service.pl"]; +} + +package main; + +my $bus = Net::DBus->session(); +my $service = $bus->export_service("org.designfu.SampleService"); +my $object = SomeObject->new($service); + +Net::DBus::Reactor->main->run(); diff --git a/examples/example-signal-emitter.pl b/examples/example-signal-emitter.pl new file mode 100644 index 0000000..ddf2c2a --- /dev/null +++ b/examples/example-signal-emitter.pl @@ -0,0 +1,49 @@ +#!/usr/bin/perl -w + +use warnings; +use strict; + +use Net::DBus; +use Net::DBus::Reactor; +use Net::DBus::Service; +use Net::DBus::Object; + +use Carp qw(confess cluck); + +#$SIG{__WARN__} = sub { cluck $_[0] }; +#$SIG{__DIE__} = sub { confess $_[0] }; + +package TestObject; + +use base qw(Net::DBus::Object); +use Net::DBus::Exporter qw(org.designfu.TestService); + +sub new { + my $class = shift; + my $service = shift; + my $self = $class->SUPER::new($service, "/org/designfu/TestService/object"); + + bless $self, $class; + + return $self; +} + +dbus_signal("HelloSignal", ["string"]); +dbus_method("emitHelloSignal"); +sub emitHelloSignal { + my $self = shift; + print "Got request to send hello signal\n"; + return $self->emit_signal("HelloSignal", "Hello"); +} + + +package main; + + +my $bus = Net::DBus->session(); +my $service = $bus->export_service("org.designfu.TestService"); +my $object = TestObject->new($service); + +Net::DBus::Reactor->main->run(); + + diff --git a/examples/example-signal-receiver.pl b/examples/example-signal-receiver.pl new file mode 100644 index 0000000..30f484b --- /dev/null +++ b/examples/example-signal-receiver.pl @@ -0,0 +1,52 @@ +#!/usr/bin/perl -w + +use warnings; +use strict; + +use Net::DBus; +use Net::DBus::Reactor; + +use Carp qw(confess cluck); + +#$SIG{__WARN__} = sub { cluck $_[0] }; +#$SIG{__DIE__} = sub { confess $_[0] }; + +my $bus = Net::DBus->session(); + +my $service = $bus->get_service("org.designfu.TestService"); +my $object = $service->get_object("/org/designfu/TestService/object", + "org.designfu.TestService"); + +my $sig1; +my $sig2; + +my $sig1ref = \$sig1; +my $sig2ref = \$sig2; + +sub hello_signal_handler1 { + my $greeting = shift; + print ${$sig1ref} . " Received hello signal with greeting '$greeting'\n"; + +} +sub hello_signal_handler2 { + my $greeting = shift; + print ${$sig2ref} . " Received hello signal with greeting '$greeting'\n"; + + $object->disconnect_from_signal("HelloSignal", ${$sig2ref}); + ${$sig2ref} = undef; +} + +$sig1 = $object->connect_to_signal("HelloSignal", \&hello_signal_handler1); +$sig2 = $object->connect_to_signal("HelloSignal", \&hello_signal_handler2); + +my $reactor = Net::DBus::Reactor->main(); + +my $ticks = 0; +$reactor->add_timeout(5000, sub { + $object->emitHelloSignal(); + if ($ticks++ == 10) { + $reactor->shutdown(); + } +}); + +$reactor->run(); diff --git a/examples/lshal.pl b/examples/lshal.pl new file mode 100644 index 0000000..9151d1c --- /dev/null +++ b/examples/lshal.pl @@ -0,0 +1,22 @@ +#!/usr/bin/perl -w + +use strict; +use Net::DBus; + +my $bus = Net::DBus->system; + +# Get a handle to the HAL service +my $hal = $bus->get_service("org.freedesktop.Hal"); + +# Get the device manager +my $manager = $hal->get_object("/org/freedesktop/Hal/Manager", "org.freedesktop.Hal.Manager"); + +print "Warning. There may be a slight pause while this next\n"; +print "method times out, if your version of HAL still just\n"; +print "silently ignores unsupported method calls, rather than\n"; +print "returning an error. The timeout is ~60 seconds\n"; + +# List devices +foreach my $dev (sort { $a cmp $b } @{$manager->GetAllDevices}) { + print $dev, "\n"; +} diff --git a/examples/notification.pl b/examples/notification.pl new file mode 100644 index 0000000..bbcafb5 --- /dev/null +++ b/examples/notification.pl @@ -0,0 +1,19 @@ +#!/usr/bin/perl + +use Net::DBus qw(:typing); + + +my $bus = Net::DBus->session; + +my $svc = $bus->get_service("org.freedesktop.Notifications"); +my $obj = $svc->get_object("/org/freedesktop/Notifications"); + +$obj->Notify("notification.pl", + 0, + '', + "Demo notification", + "Demonstrating using of desktop\n" . + "notifications from Net::DBus\n", + ["done", "Done"], + {"desktop-entry" => "virt-manager", x => dbus_variant(dbus_int32(200)), y => dbus_variant(dbus_int32(200))}, + 2_000); diff --git a/examples/strict-exports.pl b/examples/strict-exports.pl new file mode 100644 index 0000000..e6b0e07 --- /dev/null +++ b/examples/strict-exports.pl @@ -0,0 +1,75 @@ +#!/usr/bin/perl +# -*- perl -*- + +use strict; +use warnings; + +package MyStrictObject; + +use base qw(Net::DBus::Object); +use Net::DBus::Exporter "org.example.MyObject"; + +sub new { + my $class = shift; + my $self = $class->SUPER::new(@_); + + $self->{name} = "Joe"; + $self->{salary} = 100000; + + bless $self, $class; + + return $self; +} + +dbus_method("name", [], ["string"]); +sub name { + my $self = shift; + return $self->{name}; +} + +sub salary { + my $self = shift; + return $self->{salary}; +} + +package MyFlexibleObject; + +use base qw(Net::DBus::Object); +use Net::DBus::Exporter qw(org.example.MyObject); + +dbus_no_strict_exports; + +sub new { + my $class = shift; + my $self = $class->SUPER::new(@_); + + $self->{name} = "Joe"; + $self->{salary} = 100000; + + bless $self, $class; + + return $self; +} + +dbus_method("name", [], ["string"]); +sub name { + my $self = shift; + return $self->{name}; +} + +sub salary { + my $self = shift; + return $self->{salary}; +} + +package main; + +use Net::DBus; +use Net::DBus::Reactor; + +my $bus = Net::DBus->session; +my $service = $bus->export_service("org.cpan.Net.Bus.test"); +my $object1 = MyStrictObject->new($service, "/org/example/MyStrictObject"); +my $object2 = MyFlexibleObject->new($service, "/org/example/MyFlexibleObject"); + +Net::DBus::Reactor->main->run(); diff --git a/lib/Net/DBus.pm b/lib/Net/DBus.pm new file mode 100644 index 0000000..2876d37 --- /dev/null +++ b/lib/Net/DBus.pm @@ -0,0 +1,746 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus - Perl extension for the DBus message system + +=head1 SYNOPSIS + + + ####### Attaching to the bus ########### + + use Net::DBus; + + # Find the most appropriate bus + my $bus = Net::DBus->find; + + # ... or explicitly go for the session bus + my $bus = Net::DBus->session; + + # .... or explicitly go for the system bus + my $bus = Net::DBus->system + + + ######## Accessing remote services ######### + + # Get a handle to the HAL service + my $hal = $bus->get_service("org.freedesktop.Hal"); + + # Get the device manager + my $manager = $hal->get_object("/org/freedesktop/Hal/Manager", + "org.freedesktop.Hal.Manager"); + + # List devices + foreach my $dev (@{$manager->GetAllDevices}) { + print $dev, "\n"; + } + + + ######### Providing services ############## + + # Register a service known as 'org.example.Jukebox' + my $service = $bus->export_service("org.example.Jukebox"); + + +=head1 DESCRIPTION + +Net::DBus provides a Perl API for the DBus message system. +The DBus Perl interface is currently operating against +the 0.32 development version of DBus, but should work with +later versions too, providing the API changes have not been +too drastic. + +Users of this package are either typically, service providers +in which case the L and L +modules are of most relevance, or are client consumers, in which +case L and L +are of most relevance. + +=head1 METHODS + +=over 4 + +=cut + +package Net::DBus; + +use 5.006; +use strict; +use warnings; + +BEGIN { + our $VERSION = '1.0.0'; + require XSLoader; + XSLoader::load('Net::DBus', $VERSION); +} + +use Net::DBus::Binding::Bus; +use Net::DBus::Service; +use Net::DBus::RemoteService; +use Net::DBus::Test::MockConnection; +use Net::DBus::Binding::Value; + +use vars qw($bus_system $bus_session); + +use Exporter qw(import); + +use vars qw(@EXPORT_OK %EXPORT_TAGS); + +@EXPORT_OK = qw(dbus_int16 dbus_uint16 dbus_int32 dbus_uint32 dbus_int64 dbus_uint64 + dbus_byte dbus_boolean dbus_string dbus_double + dbus_object_path dbus_signature + dbus_struct dbus_array dbus_dict dbus_variant); + +%EXPORT_TAGS = (typing => [qw(dbus_int16 dbus_uint16 dbus_int32 dbus_uint32 dbus_int64 dbus_uint64 + dbus_byte dbus_boolean dbus_string dbus_double + dbus_object_path dbus_signature + dbus_struct dbus_array dbus_dict dbus_variant)]); + +=item my $bus = Net::DBus->find(%params); + +Search for the most appropriate bus to connect to and +return a connection to it. The heuristic used for the +search is + + - If DBUS_STARTER_BUS_TYPE is set to 'session' attach + to the session bus + + - Else If DBUS_STARTER_BUS_TYPE is set to 'system' attach + to the system bus + + - Else If DBUS_SESSION_BUS_ADDRESS is set attach to the + session bus + + - Else attach to the system bus + +The optional C hash can contain be used to specify +connection options. The only support option at this time +is C which prevents the bus from being automatically +attached to the main L event loop. + +=cut + +sub find { + my $class = shift; + + if ($ENV{DBUS_STARTER_BUS_TYPE} && + $ENV{DBUS_STARTER_BUS_TYPE} eq "session") { + return $class->session(@_); + } elsif ($ENV{DBUS_STARTER_BUS_TYPE} && + $ENV{DBUS_STARTER_BUS_TYPE} eq "system") { + return $class->system(@_); + } elsif (exists $ENV{DBUS_SESSION_BUS_ADDRESS}) { + return $class->session(@_); + } else { + return $class->system; + } +} + +=item my $bus = Net::DBus->system(%params); + +Return a handle for the system message bus. Note that the +system message bus is locked down by default, so unless appropriate +access control rules are added in /etc/dbus/system.d/, an application +may access services, but won't be able to export services. +The optional C hash can contain be used to specify +connection options. The only support option at this time +is C which prevents the bus from being automatically +attached to the main L event loop. + +=cut + +sub system { + my $class = shift; + my %params = @_; + if ($params{private}) { + return $class->_new(Net::DBus::Binding::Bus->new(type => &Net::DBus::Binding::Bus::SYSTEM, private => 1), @_); + } + + unless ($bus_system) { + $bus_system = $class->_new(Net::DBus::Binding::Bus->new(type => &Net::DBus::Binding::Bus::SYSTEM), @_); + } + return $bus_system +} + +=item my $bus = Net::DBus->session(%params); + +Return a handle for the session message bus. +The optional C hash can contain be used to specify +connection options. The only support option at this time +is C which prevents the bus from being automatically +attached to the main L event loop. + +=cut + +sub session { + my $class = shift; + my %params = @_; + if ($params{private}) { + return $class->_new(Net::DBus::Binding::Bus->new(type => &Net::DBus::Binding::Bus::SESSION, private => 1), @_); + } + + unless ($bus_session) { + $bus_session = $class->_new(Net::DBus::Binding::Bus->new(type => &Net::DBus::Binding::Bus::SESSION), @_); + } + return $bus_session; +} + + +=item my $bus = Net::DBus->test(%params); + +Returns a handle for a virtual bus for use in unit tests. This bus does +not make any network connections, but rather has an in-memory message +pipeline. Consult L for further details +of how to use this special bus. + +=cut + +# NB. explicitly do *NOT* cache, since unit tests +# should always have pristine state +sub test { + my $class = shift; + return $class->_new(Net::DBus::Test::MockConnection->new()); +} + +=item my $bus = Net::DBus->new($address, %params); + +Return a connection to a specific message bus. The C<$address> +parameter must contain the address of the message bus to connect +to. An example address for a session bus might look like +C, +while one for a system bus would look like C. +The optional C hash can contain be used to specify +connection options. The only support option at this time +is C which prevents the bus from being automatically +attached to the main L event loop. + +=cut + +sub new { + my $class = shift; + my $nomainloop = shift; + return $class->_new(Net::DBus::Binding::Bus->new(address => shift), @_); +} + +sub _new { + my $class = shift; + my $self = {}; + + $self->{connection} = shift; + $self->{signals} = []; + # Map well known names to RemoteService objects + $self->{services} = {}; + + my %params = @_; + + bless $self, $class; + + unless ($params{nomainloop}) { + if (exists $INC{'Net/DBus/Reactor.pm'}) { + my $reactor = $params{reactor} ? $params{reactor} : Net::DBus::Reactor->main; + $reactor->manage($self->get_connection); + } + # ... Add support for GLib and POE + } + + $self->get_connection->add_filter(sub { return $self->_signal_func(@_); }); + + $self->{bus} = $self->{services}->{"org.freedesktop.DBus"} = + Net::DBus::RemoteService->new($self, "org.freedesktop.DBus", "org.freedesktop.DBus"); + $self->get_bus_object()->connect_to_signal('NameOwnerChanged', sub { + my ($svc, $old, $new) = @_; + # Slightly evil poking into the private 'owner_name' field here + if (exists $self->{services}->{$svc}) { + $self->{services}->{$svc}->{owner_name} = $new; + } + }); + + return $self; +} + +=item my $connection = $bus->get_connection; + +Return a handle to the underlying, low level connection object +associated with this bus. The returned object will be an instance +of the L class. This method is not intended +for use by (most!) application developers, so if you don't understand +what this is for, then you don't need to be calling it! + +=cut + +sub get_connection { + my $self = shift; + return $self->{connection}; +} + +=item my $service = $bus->get_service($name); + +Retrieves a handle for the remote service identified by the +service name C<$name>. The returned object will be an instance +of the L class. + +=cut + +sub get_service { + my $self = shift; + my $name = shift; + + if ($name eq "org.freedesktop.DBus") { + return $self->{bus}; + } + + if (!exists $self->{services}->{$name}) { + my $owner = $name; + if ($owner !~ /^:/) { + $owner = $self->get_service_owner($name); + if (!defined $owner) { + $self->get_bus_object->StartServiceByName($name, 0); + $owner = $self->get_service_owner($name); + } + } + $self->{services}->{$name} = Net::DBus::RemoteService->new($self, $owner, $name); + } + return $self->{services}->{$name}; +} + +=item my $service = $bus->export_service($name); + +Registers a service with the bus, returning a handle to +the service. The returned object is an instance of the +L class. + +=cut + +sub export_service { + my $self = shift; + my $name = shift; + return Net::DBus::Service->new($self, $name); +} + +=item my $object = $bus->get_bus_object; + +Retrieves a handle to the bus object, C, +provided by the service C. The returned +object is an instance of L + +=cut + +sub get_bus_object { + my $self = shift; + + my $service = $self->get_service("org.freedesktop.DBus"); + return $service->get_object('/org/freedesktop/DBus', + 'org.freedesktop.DBus'); +} + + +=item my $name = $bus->get_unique_name; + +Retrieves the unique name of this client's connection to +the bus. + +=cut + +sub get_unique_name { + my $self = shift; + + return $self->get_connection->get_unique_name +} + +=item my $name = $bus->get_service_owner($service); + +Retrieves the unique name of the client on the bus owning +the service named by the C<$service> parameter. + +=cut + +sub get_service_owner { + my $self = shift; + my $service = shift; + + my $bus = $self->get_bus_object; + my $owner = eval { + $bus->GetNameOwner($service); + }; + if ($@) { + if (UNIVERSAL::isa($@, "Net::DBus::Error") && + $@->{name} eq "org.freedesktop.DBus.Error.NameHasNoOwner") { + $owner = undef; + } else { + die $@; + } + } + return $owner; +} + + +sub _add_signal_receiver { + my $self = shift; + my $receiver = shift; + my $signal_name = shift; + my $interface = shift; + my $service = shift; + my $path = shift; + + my $rule = $self->_match_rule($signal_name, $interface, $service, $path); + push @{$self->{signals}}, { cb => $receiver, + rule => $rule, + signal_name => $signal_name, + interface => $interface, + service => $service, + path => $path }; + $self->{connection}->add_match($rule); +} + +sub _remove_signal_receiver { + my $self = shift; + my $receiver = shift; + my $signal_name = shift; + my $interface = shift; + my $service = shift; + my $path = shift; + + my $rule = $self->_match_rule($signal_name, $interface, $service, $path); + my @signals; + foreach (@{$self->{signals}}) { + if ($_->{cb} eq $receiver && + $_->{rule} eq $rule) { + $self->{connection}->remove_match($rule); + } else { + push @signals, $_; + } + } + $self->{signals} = \@signals; +} + + +sub _match_rule { + my $self = shift; + my $signal_name = shift; + my $interface = shift; + my $service = shift; + my $path = shift; + + my $rule = "type='signal'"; + if (defined $interface) { + $rule .= ",interface='$interface'"; + } + if (defined $path) { + $rule .= ",path='$path'"; + } + if (defined $service) { + $rule .= ",sender='$service'"; + } + if (defined $signal_name) { + $rule .= ",member='$signal_name'"; + } + return $rule; +} + + +sub _handler_matches { + my $self = shift; + my $handler = shift; + my $signal_name = shift; + my $interface = shift; + my $sender = shift; + my $path = shift; + + if (defined $handler->{signal_name} && + $handler->{signal_name} ne $signal_name) { + return 0; + } + if (defined $handler->{interface} && + $handler->{interface} ne $interface) { + return 0; + } + if (defined $handler->{path} && + $handler->{path} ne $path) { + return 0; + } + + if (defined $handler->{service}) { + my $owner = $self->{services}->{$handler->{service}}; + return 0 unless defined $owner; + return 0 unless $owner->get_owner_name eq $sender; + } + + return 1; +} + +sub _signal_func { + my $self = shift; + my $connection = shift; + my $message = shift; + + return 0 unless $message->get_type() == &Net::DBus::Binding::Message::MESSAGE_TYPE_SIGNAL; + + my $interface = $message->get_interface; + my $sender = $message->get_sender; + my $path = $message->get_path; + my $signal_name = $message->get_member; + + my $handled = 0; + foreach my $handler (@{$self->{signals}}) { + next unless $self->_handler_matches($handler, $signal_name, $interface, $sender, $path); + my $callback = $handler->{cb}; + &$callback($message); + $handled = 1; + } + + return $handled; +} + +=back + +=head1 DATA TYPING METHODS + +These methods are not usually used, since most services provide introspection +data to inform clients of their data typing requirements. If introspection data +is incomplete, however, it may be necessary for a client to mark values with +specific data types. In such a case, the following methods can be used. They +are not, however, exported by default so must be requested at import time by +specifying 'use Net::DBus qw(:typing)' + +=over 4 + +=item $typed_value = dbus_int16($value); + +Mark a value as being a signed, 16-bit integer. + +=cut + +sub dbus_int16 { + return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_INT16, + $_[0]); + +} + +=item $typed_value = dbus_uint16($value); + +Mark a value as being an unsigned, 16-bit integer. + +=cut + + +sub dbus_uint16 { + return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_UINT16, + $_[0]); +} + +=item $typed_value = dbus_int32($value); + +Mark a value as being a signed, 32-bit integer. + +=cut + +sub dbus_int32 { + return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_INT32, + $_[0]); + +} + +=item $typed_value = dbus_uint32($value); + +Mark a value as being an unsigned, 32-bit integer. + +=cut + + +sub dbus_uint32 { + return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_UINT32, + $_[0]); +} + +=item $typed_value = dbus_int64($value); + +Mark a value as being an unsigned, 64-bit integer. + +=cut + + + +sub dbus_int64 { + return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_INT64, + $_[0]); + +} + +=item $typed_value = dbus_uint64($value); + +Mark a value as being an unsigned, 64-bit integer. + +=cut + + + +sub dbus_uint64 { + return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_UINT64, + $_[0]); +} + +=item $typed_value = dbus_double($value); + +Mark a value as being a double precision IEEE floating point. + +=cut + + + +sub dbus_double { + return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_DOUBLE, + $_[0]); +} + +=item $typed_value = dbus_byte($value); + +Mark a value as being an unsigned, byte. + +=cut + + + +sub dbus_byte { + return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_BYTE, + $_[0]); +} + +=item $typed_value = dbus_string($value); + +Mark a value as being a UTF-8 string. This is not usually required +since 'string' is the default data type for any Perl scalar value. + +=cut + + + +sub dbus_string { + return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_STRING, + $_[0]); +} + +=item $typed_value = dbus_signature($value); + +Mark a value as being a UTF-8 string, whose contents is a valid +type signature + +=cut + + + +sub dbus_signature { + return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_SIGNATURE, + $_[0]); +} + +=item $typed_value = dbus_object_path($value); + +Mark a value as being a UTF-8 string, whose contents is a valid +object path. + +=cut + +sub dbus_object_path { + return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_OBJECT_PATH, + $_[0]); +} + +=item $typed_value = dbus_boolean($value); + +Mark a value as being an boolean + +=cut + + + +sub dbus_boolean { + return Net::DBus::Binding::Value->new(&Net::DBus::Binding::Message::TYPE_BOOLEAN, + $_[0]); +} + +=item $typed_value = dbus_array($value); + +Mark a value as being an array + +=cut + + +sub dbus_array { + return Net::DBus::Binding::Value->new([&Net::DBus::Binding::Message::TYPE_ARRAY], + $_[0]); +} + +=item $typed_value = dbus_struct($value); + +Mark a value as being a structure + +=cut + + +sub dbus_struct { + return Net::DBus::Binding::Value->new([&Net::DBus::Binding::Message::TYPE_STRUCT], + $_[0]); +} + +=item $typed_value = dbus_dict($value); + +Mark a value as being a dictionary + +=cut + +sub dbus_dict{ + return Net::DBus::Binding::Value->new([&Net::DBus::Binding::Message::TYPE_DICT_ENTRY], + $_[0]); +} + +=item $typed_value = dbus_variant($value); + +Mark a value as being a variant + +=cut + +sub dbus_variant{ + return Net::DBus::Binding::Value->new([&Net::DBus::Binding::Message::TYPE_VARIANT], + $_[0]); +} + +=pod + +=back + +=head1 SEE ALSO + +L, L, L, +L, L, +L, L, L, +C, C, C, L, + +=head1 AUTHOR + +Daniel Berrange + +=head1 COPYRIGHT + +Copyright 2004-2011 by Daniel Berrange + +=cut + +1; diff --git a/lib/Net/DBus/ASyncReply.pm b/lib/Net/DBus/ASyncReply.pm new file mode 100644 index 0000000..ca526c8 --- /dev/null +++ b/lib/Net/DBus/ASyncReply.pm @@ -0,0 +1,192 @@ +# -*- perl -*- +# +# Copyright (C) 2006-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::ASyncReply - asynchronous method reply handler + +=head1 SYNOPSIS + + use Net::DBus::Annotation qw(:call); + + my $object = $service->get_object("/org/example/systemMonitor"); + + # List processes & get on with other work until + # the list is returned. + my $asyncreply = $object->list_processes(dbus_call_async, "someuser"); + + while (!$asyncreply->is_ready) { + ... do some background work.. + } + + my $processes = $asyncreply->get_result; + + +=head1 DESCRIPTION + +This object provides a handler for receiving asynchronous +method replies. An asynchronous reply object is generated +when making remote method call with the C +annotation set. + +=head1 METHODS + +=over 4 + +=cut + +package Net::DBus::ASyncReply; + +use strict; +use warnings; + + +sub _new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = {}; + my %params = @_; + + $self->{pending_call} = $params{pending_call} ? $params{pending_call} : die "pending_call parameter is required"; + $self->{introspector} = $params{introspector} ? $params{introspector} : undef; + $self->{method_name} = $params{method_name} ? $params{method_name} : ($self->{introspector} ? die "method_name is parameter required for introspection" : undef); + + bless $self, $class; + + return $self; +} + + +=item $asyncreply->discard_result; + +Indicates that the caller is no longer interested in +recieving the reply & that it should be discarded. After +calling this method, this object should not be used again. + +=cut + +sub discard_result { + my $self = shift; + + $self->{pending_call}->cancel; +} + + +=item $asyncreply->wait_for_result; + +Blocks the caller waiting for completion of the of the +asynchronous reply. Upon returning from this method, the +result can be obtained with the C method. + +=cut + +sub wait_for_result { + my $self = shift; + + $self->{pending_call}->block; +} + +=item my $boolean = $asyncreply->is_ready; + +Returns a true value if the asynchronous reply is now +complete (or a timeout has occurred). When this method +returns true, the result can be obtained with the C +method. + +=cut + +sub is_ready { + my $self = shift; + + return $self->{pending_call}->get_completed; +} + + +=item $asyncreply->set_notify($coderef); + +Sets a notify function which will be invoked when the +asynchronous reply finally completes. The callback will +be invoked with a single parameter which is this object. + +=cut + +sub set_notify { + my $self = shift; + my $cb = shift; + + $self->{pending_call}->set_notify(sub { + my $pending_call = shift; + + &$cb($self); + }); +} + +=item my @data = $asyncreply->get_result; + +Retrieves the data associated with the asynchronous reply. +If a timeout occurred, then this method will throw an +exception. This method can only be called once the reply +is complete, as indicated by the C method +returning a true value. After calling this method, this +object should no longer be used. + +=cut + +sub get_result { + my $self = shift; + + my $reply = $self->{pending_call}->get_reply; + + if ($reply->isa("Net::DBus::Binding::Message::Error")) { + my $iter = $reply->iterator(); + my $desc = $iter->get_string(); + die Net::DBus::Error->new(name => $reply->get_error_name, + message => $desc); + } + + my @reply; + if ($self->{introspector}) { + @reply = $self->{introspector}->decode($reply, "methods", $self->{method_name}, "returns"); + } else { + @reply = $reply->get_args_list; + } + + return wantarray ? @reply : $reply[0]; +} + +1; + +=pod + +=back + +=head1 AUTHOR + +Daniel Berrange + +=head1 COPYRIGHT + +Copright (C) 2006-2011, Daniel Berrange. + +=head1 SEE ALSO + +L, L, L + +=cut diff --git a/lib/Net/DBus/Annotation.pm b/lib/Net/DBus/Annotation.pm new file mode 100644 index 0000000..0161580 --- /dev/null +++ b/lib/Net/DBus/Annotation.pm @@ -0,0 +1,131 @@ +# -*- perl -*- +# +# Copyright (C) 2006-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Annotation - annotations for changing behaviour of APIs + +=head1 SYNOPSIS + + use Net::DBus::Annotation qw(:call); + + my $object = $service->get_object("/org/example/systemMonitor"); + + # Block until processes are listed + my $processes = $object->list_processes("someuser"); + + # Just throw away list of processes, pretty pointless + # in this example, but useful if the method doesn't have + # a return value + $object->list_processes(dbus_call_noreply, "someuser"); + + # List processes & get on with other work until + # the list is returned. + my $asyncreply = $object->list_processes(dbus_call_async, "someuser"); + + ... some time later... + my $processes = $asyncreply->get_data; + +=head1 DESCRIPTION + +This module provides a number of annotations which will be useful +when dealing with the DBus APIs. There are annotations for switching +remote calls between sync, async and no-reply mode. More annotations +may be added over time. + +=head1 METHODS + +=over 4 + +=cut + +package Net::DBus::Annotation; + +use strict; +use warnings; + +our $CALL_SYNC = "sync"; +our $CALL_ASYNC = "async"; +our $CALL_NOREPLY = "noreply"; + +bless \$CALL_SYNC, __PACKAGE__; +bless \$CALL_ASYNC, __PACKAGE__; +bless \$CALL_NOREPLY, __PACKAGE__; + +require Exporter; + +our @ISA = qw(Exporter); +our @EXPORT_OK = qw(dbus_call_sync dbus_call_async dbus_call_noreply); +our %EXPORT_TAGS = (call => [qw(dbus_call_sync dbus_call_async dbus_call_noreply)]); + +=item dbus_call_sync + +Requests that a method call be performed synchronously, waiting +for the reply or error return to be received before continuing. + +=cut + +sub dbus_call_sync() { + return \$CALL_SYNC; +} + + +=item dbus_call_async + +Requests that a method call be performed a-synchronously, returning +a pending call object, which will collect the reply when it eventually +arrives. + +=cut + +sub dbus_call_async() { + return \$CALL_ASYNC; +} + +=item dbus_call_noreply + +Requests that a method call be performed a-synchronously, discarding +any possible reply or error message. + +=cut + +sub dbus_call_noreply() { + return \$CALL_NOREPLY; +} + +1; + +=pod + +=back + +=head1 AUTHOR + +Daniel Berrange + +=head1 COPYRIGHT + +Copright (C) 2006-2011, Daniel Berrange. + +=head1 SEE ALSO + +L, L + +=cut diff --git a/lib/Net/DBus/Binding/Bus.pm b/lib/Net/DBus/Binding/Bus.pm new file mode 100644 index 0000000..e126148 --- /dev/null +++ b/lib/Net/DBus/Binding/Bus.pm @@ -0,0 +1,202 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Binding::Bus - Handle to a well-known message bus instance + +=head1 SYNOPSIS + + use Net::DBus::Binding::Bus; + + # Get a handle to the system bus + my $bus = Net::DBus::Binding::Bus->new(type => &Net::DBus::Binding::Bus::SYSTEM); + +=head1 DESCRIPTION + +This is a specialization of the L +module providing convenience constructor for connecting to one of +the well-known bus types. There is no reason to use this module +directly, instead get a handle to the bus with the C or +C methods in L. + +=head1 METHODS + +=over 4 + +=cut + +package Net::DBus::Binding::Bus; + +use 5.006; +use strict; +use warnings; + +use Net::DBus; + +use base qw(Net::DBus::Binding::Connection); + +=item my $bus = Net::DBus::Binding::Bus->new(type => $type); + +=item my $bus = Net::DBus::Binding::Bus->new(address => $addr); + +Open a connection to a message bus, either a well known bus type +specified using the C parameter, or an arbitrary bus specified +using the C
parameter. If the C parameter is set +to a true value, then a private connection to the bus is obtained. +The caller must explicitly disconnect this bus instance before +releasing the last instance of the object. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my %params = @_; + + my $connection; + if (defined $params{type}) { + if ($params{private}) { + $connection = Net::DBus::Binding::Bus::_open_private($params{type}); + } else { + $connection = Net::DBus::Binding::Bus::_open($params{type}); + } + } elsif (defined $params{address}) { + if ($params{private}) { + $connection = Net::DBus::Binding::Connection::_open_private($params{address}); + } else { + $connection = Net::DBus::Binding::Connection::_open($params{address}); + } + $connection->dbus_bus_register(); + } else { + die "either type or address parameter is required"; + } + + my $self = $class->SUPER::new(%params, connection => $connection); + + bless $self, $class; + + return $self; +} + + +=item $bus->request_name($service_name) + +Send a request to the bus registering the well known name +specified in the C<$service_name> parameter. If another client +already owns the name, registration will be queued up, pending +the exit of the other client. + +=cut + +sub request_name { + my $self = shift; + my $service_name = shift; + + $self->{connection}->dbus_bus_request_name($service_name); +} + +=item my $name = $bus->get_unique_name + +Returns the unique name by which this processes' connection to +the bus is known. Unique names are never re-used for the entire +lifetime of the bus daemon. + +=cut + +sub get_unique_name { + my $self = shift; + + $self->{connection}->dbus_bus_get_unique_name; +} + + +=item $bus->add_match($rule) + +Register a signal match rule with the bus controller, allowing +matching broadcast signals to routed to this client. + +=cut + +sub add_match { + my $self = shift; + my $rule = shift; + + $self->{connection}->dbus_bus_add_match($rule); +} + +=item $bus->remove_match($rule) + +Unregister a signal match rule with the bus controller, preventing +further broadcast signals being routed to this client + +=cut + +sub remove_match { + my $self = shift; + my $rule = shift; + + $self->{connection}->dbus_bus_remove_match($rule); +} + +sub DESTROY { + # Keep autoloader quiet +} + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. + + my $constname; + our $AUTOLOAD; + ($constname = $AUTOLOAD) =~ s/.*:://; + + die "&Net::DBus::Binding::Bus::constant not defined" if $constname eq '_constant'; + + if (!exists $Net::DBus::Binding::Bus::_constants{$constname}) { + die "no such method $constname, and no constant \$Net::DBus::Binding::Bus::$constname"; + } + + { + no strict 'refs'; + *$AUTOLOAD = sub { $Net::DBus::Binding::Bus::_constants{$constname} }; + } + goto &$AUTOLOAD; +} + +1; + +=pod + +=back + +=head1 AUTHOR + +Daniel P. Berrange + +=head1 COPYRIGHT + +Copyright (C) 2004-2011 Daniel P. Berrange + +=head1 SEE ALSO + +L, L + +=cut diff --git a/lib/Net/DBus/Binding/Connection.pm b/lib/Net/DBus/Binding/Connection.pm new file mode 100644 index 0000000..3020def --- /dev/null +++ b/lib/Net/DBus/Binding/Connection.pm @@ -0,0 +1,655 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Binding::Connection - A connection between client and server + +=head1 SYNOPSIS + +Creating a connection to a server and sending a message + + use Net::DBus::Binding::Connection; + + my $con = Net::DBus::Binding::Connection->new(address => "unix:path=/path/to/socket"); + + $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 = Net::DBus::Binding::Reactor->new(); + + $reactor->manage($con); + + $reactor->run(); + +=head1 DESCRIPTION + +An outgoing connection to a server, or an incoming connection +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 + +package Net::DBus::Binding::Connection; + +use 5.006; +use strict; +use warnings; + +use Net::DBus; +use Net::DBus::Binding::Message::MethodCall; +use Net::DBus::Binding::Message::MethodReturn; +use Net::DBus::Binding::Message::Error; +use Net::DBus::Binding::Message::Signal; +use Net::DBus::Binding::PendingCall; + +=item my $con = Net::DBus::Binding::Connection->new(address => "unix:path=/path/to/socket"); + +Creates a new connection to the remove server specified by +the parameter C
. If the C parameter is +supplied, and set to a True value the connection opened is +private; otherwise a shared connection is opened. A private +connection must be explicitly shutdown with the C +method before the last reference to the object is released. +A shared connection must never be explicitly disconnected. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my %params = @_; + my $self = {}; + + my $private = $params{private} ? $params{private} : 0; + $self->{address} = exists $params{address} ? $params{address} : (exists $params{connection} ? "" : die "address parameter is required"); + $self->{connection} = exists $params{connection} ? $params{connection} : + ($private ? + Net::DBus::Binding::Connection::_open_private($self->{address}) : + Net::DBus::Binding::Connection::_open($self->{address})); + + bless $self, $class; + + $self->{connection}->_set_owner($self); + + return $self; +} + + +=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(); +} + +=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(); +} + + +=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; + + $self->{connection}->dbus_connection_disconnect(); +} + +=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; + + $self->{connection}->dbus_connection_flush(); +} + + +=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. 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; + + return $self->{connection}->_send($msg->{message}); +} + +=item my $reply = $con->send_with_reply_and_block($msg, $timeout); + +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 or C +object. + +=cut + +sub send_with_reply_and_block { + my $self = shift; + my $msg = shift; + my $timeout = shift; + + my $reply = $self->{connection}->_send_with_reply_and_block($msg->{message}, $timeout); + + my $type = $reply->dbus_message_get_type; + if ($type == &Net::DBus::Binding::Message::MESSAGE_TYPE_ERROR) { + return $self->make_raw_message($reply); + } elsif ($type == &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN) { + return $self->make_raw_message($reply); + } else { + die "unknown method reply type $type"; + } +} + + +=item my $pending_call = $con->send_with_reply($msg, $timeout); + +Queues a message up for sending to the remote host +and returns immediately providing a reference to a +C object. This object +can be used to wait / watch for a reply. This allows +methods to be processed asynchronously. + +=cut + +sub send_with_reply { + my $self = shift; + my $msg = shift; + my $timeout = shift; + + my $reply = $self->{connection}->_send_with_reply($msg->{message}, $timeout); + + return Net::DBus::Binding::PendingCall->new(connection => $self, + method_call => $msg, + pending_call => $reply); +} + + +=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(); +} + + +=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 method, or removed +permanently with th C method as soon as +is practical. + +=cut + +sub borrow_message { + my $self = shift; + + my $msg = $self->{connection}->dbus_connection_borrow_message(); + return $self->make_raw_message($msg); +} + +=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}); +} + + +=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}); +} + +=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 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 $self->make_raw_message($msg); +} + +=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 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; + my $remove = shift; + my $toggled = shift; + + $self->{add_watch} = $add; + $self->{remove_watch} = $remove; + $self->{toggled_watch} = $toggled; + + $self->{connection}->_set_watch_callbacks(); +} + +=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 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->{connection}->_set_timeout_callbacks(); +} + +=item $con->register_object_path($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 class). + +=cut + +sub register_object_path { + my $self = shift; + my $path = shift; + my $code = shift; + + my $callback = sub { + my $con = shift; + my $msg = shift; + + &$code($con, $self->make_raw_message($msg)); + }; + $self->{connection}->_register_object_path($path, $callback); +} + +=item $con->unregister_object_path($path) + +Unregisters the handler associated with the object path C<$path>. The +handler would previously have been registered with the C +or C methods. + +=cut + +sub unregister_object_path { + my $self = shift; + my $path = shift; + $self->{connection}->_unregister_object_path($path); +} + + +=item $con->register_fallback($path, \&handler) + +Registers a handler for messages whose path starts with +the prefix 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 class). + +=cut + +sub register_fallback { + my $self = shift; + my $path = shift; + my $code = shift; + + my $callback = sub { + my $con = shift; + my $msg = shift; + + &$code($con, $self->make_raw_message($msg)); + }; + + $self->{connection}->_register_fallback($path, $callback); +} + + +=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); +} + +=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; +} + +=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); +} + +=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; +} + + +=item $con->add_filter($coderef); + +Adds a filter to the connection which will be invoked whenever a +message is received. The C<$coderef> should be a reference to a +subroutine, which returns a true value if the message should be +filtered out, or a false value if the normal message dispatch +should be performed. + +=cut + +sub add_filter { + my $self = shift; + my $callback = shift; + + $self->{connection}->_add_filter($callback); +} + + +sub _message_filter { + my $self = shift; + my $rawmsg = shift; + my $code = shift; + + my $msg = $self->make_raw_message($rawmsg); + return &$code($self, $msg); +} + + +=item my $msg = $con->make_raw_message($rawmsg) + +Creates a new message, initializing it from the low level C message +object provided by the C<$rawmsg> parameter. The returned object +will be cast to the appropriate subclass of L. + +=cut + +sub make_raw_message { + my $self = shift; + my $rawmsg = shift; + + return Net::DBus::Binding::Message->new(message => $rawmsg); +} + + +=item my $msg = $con->make_error_message( + replyto => $method_call, name => $name, description => $description); + +Creates a new message, representing an error which occurred during +the handling of the method call object passed in as the C +parameter. The C parameter is the formal name of the error +condition, while the C is a short piece of text giving +more specific information on the error. + +=cut + + +sub make_error_message { + my $self = shift; + my $replyto = shift; + my $name = shift; + my $description = shift; + + return Net::DBus::Binding::Message::Error->new(replyto => $replyto, + name => $name, + description => $description); +} + +=item my $call = $con->make_method_call_message( + $service_name, $object_path, $interface, $method_name); + +Create a message representing a call on the object located at +the path C<$object_path> within the client owning the well-known +name given by C<$service_name>. The method to be invoked has +the name C<$method_name> within the interface specified by the +C<$interface> parameter. + +=cut + + +sub make_method_call_message { + my $self = shift; + my $service_name = shift; + my $object_path = shift; + my $interface = shift; + my $method_name = shift; + + return Net::DBus::Binding::Message::MethodCall->new(service_name => $service_name, + object_path => $object_path, + interface => $interface, + method_name => $method_name); +} + +=item my $msg = $con->make_method_return_message( + replyto => $method_call); + +Create a message representing a reply to the method call passed in +the C parameter. + +=cut + + +sub make_method_return_message { + my $self = shift; + my $replyto = shift; + + return Net::DBus::Binding::Message::MethodReturn->new(call => $replyto); +} + + +=item my $signal = $con->make_signal_message( + object_path => $path, interface => $interface, signal_name => $name); + +Creates a new message, representing a signal [to be] emitted by +the object located under the path given by the C +parameter. The name of the signal is given by the C +parameter, and is scoped to the interface given by the +C parameter. + +=cut + +sub make_signal_message { + my $self = shift; + my $object_path = shift; + my $interface = shift; + my $signal_name = shift; + + return Net::DBus::Binding::Message::Signal->new(object_path => $object_path, + interface => $interface, + signal_name => $signal_name); +} + +1; + +=pod + +=back + +=head1 AUTHOR + +Daniel P. Berrange + +=head1 COPYRIGHT + +Copyright (C) 2004-2011 Daniel P. Berrange + +=head1 SEE ALSO + +L, L, L, L, L, L + +=cut diff --git a/lib/Net/DBus/Binding/Introspector.pm b/lib/Net/DBus/Binding/Introspector.pm new file mode 100644 index 0000000..2d35e20 --- /dev/null +++ b/lib/Net/DBus/Binding/Introspector.pm @@ -0,0 +1,1240 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Binding::Introspector - Handler for object introspection data + +=head1 SYNOPSIS + + # Create an object populating with info from an + # XML doc containing introspection data. + + my $ins = Net::DBus::Binding::Introspector->new(xml => $data); + + # Create an object, defining introspection data + # programmatically + my $ins = Net::DBus::Binding::Introspector->new(object_path => $object->get_object_path); + $ins->add_method("DoSomething", ["string"], [], "org.example.MyObject"); + $ins->add_method("TestSomething", ["int32"], [], "org.example.MyObject"); + +=head1 DESCRIPTION + +This class is responsible for managing introspection data, and +answering questions about it. This is not intended for use by +application developers, whom should instead consult the higher +level API in L. + +=head1 METHODS + +=over 4 + +=cut + +package Net::DBus::Binding::Introspector; + +use 5.006; +use strict; +use warnings; + +use XML::Twig; + +use Net::DBus::Binding::Message; + +our $debug = 0; + +BEGIN { + if ($ENV{NET_DBUS_DEBUG} && + $ENV{NET_DBUS_DEBUG} eq "introspect") { + $debug = 1; + } +} + +our %simple_type_map = ( + "byte" => &Net::DBus::Binding::Message::TYPE_BYTE, + "bool" => &Net::DBus::Binding::Message::TYPE_BOOLEAN, + "double" => &Net::DBus::Binding::Message::TYPE_DOUBLE, + "string" => &Net::DBus::Binding::Message::TYPE_STRING, + "int16" => &Net::DBus::Binding::Message::TYPE_INT16, + "uint16" => &Net::DBus::Binding::Message::TYPE_UINT16, + "int32" => &Net::DBus::Binding::Message::TYPE_INT32, + "uint32" => &Net::DBus::Binding::Message::TYPE_UINT32, + "int64" => &Net::DBus::Binding::Message::TYPE_INT64, + "uint64" => &Net::DBus::Binding::Message::TYPE_UINT64, + "objectpath" => &Net::DBus::Binding::Message::TYPE_OBJECT_PATH, + "signature" => &Net::DBus::Binding::Message::TYPE_SIGNATURE, +); + +our %simple_type_rev_map = ( + &Net::DBus::Binding::Message::TYPE_BYTE => "byte", + &Net::DBus::Binding::Message::TYPE_BOOLEAN => "bool", + &Net::DBus::Binding::Message::TYPE_DOUBLE => "double", + &Net::DBus::Binding::Message::TYPE_STRING => "string", + &Net::DBus::Binding::Message::TYPE_INT16 => "int16", + &Net::DBus::Binding::Message::TYPE_UINT16 => "uint16", + &Net::DBus::Binding::Message::TYPE_INT32 => "int32", + &Net::DBus::Binding::Message::TYPE_UINT32 => "uint32", + &Net::DBus::Binding::Message::TYPE_INT64 => "int64", + &Net::DBus::Binding::Message::TYPE_UINT64 => "uint64", + &Net::DBus::Binding::Message::TYPE_OBJECT_PATH => "objectpath", + &Net::DBus::Binding::Message::TYPE_SIGNATURE => "signature", +); + +our %magic_type_map = ( + "caller" => sub { + my $msg = shift; + + return $msg->get_sender; + }, + "serial" => sub { + my $msg = shift; + + return $msg->get_serial; + }, +); + +our %compound_type_map = ( + "array" => &Net::DBus::Binding::Message::TYPE_ARRAY, + "struct" => &Net::DBus::Binding::Message::TYPE_STRUCT, + "dict" => &Net::DBus::Binding::Message::TYPE_DICT_ENTRY, + "variant" => &Net::DBus::Binding::Message::TYPE_VARIANT, +); + +=item my $ins = Net::DBus::Binding::Introspector->new(object_path => $object_path, + xml => $xml); + +Creates a new introspection data manager for the object registered +at the path specified for the C parameter. The optional +C parameter can be used to pre-load the manager with introspection +metadata from an XML document. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = {}; + my %params = @_; + + $self->{interfaces} = {}; + + bless $self, $class; + + if (defined $params{xml}) { + $self->{object_path} = exists $params{object_path} ? $params{object_path} : undef; + $self->_parse($params{xml}); + } elsif (defined $params{node}) { + $self->{object_path} = exists $params{object_path} ? $params{object_path} : undef; + $self->_parse_node($params{node}); + } else { + $self->{object_path} = exists $params{object_path} ? $params{object_path} : undef; + $self->{interfaces} = $params{interfaces} if exists $params{interfaces}; + $self->{children} = exists $params{children} ? $params{children} : []; + } + + $self->{strict} = exists $params{strict} ? $params{strict} : 0; + + # Some versions of dbus failed to include signals in introspection data + # so this code adds them, letting us keep compatability with old versions + if (defined $self->{object_path} && + $self->{object_path} eq "/org/freedesktop/DBus") { + if (!$self->has_signal("NameOwnerChanged")) { + $self->add_signal("NameOwnerChanged", ["string","string","string"], "org.freedesktop.DBus"); + } + if (!$self->has_signal("NameLost")) { + $self->add_signal("NameLost", ["string"], "org.freedesktop.DBus"); + } + if (!$self->has_signal("NameAcquired")) { + $self->add_signal("NameAcquired", ["string"], "org.freedesktop.DBus"); + } + } + + return $self; +} + +=item $ins->add_interface($name) + +Register the object as providing an interface with the name C<$name> + +=cut + +sub add_interface { + my $self = shift; + my $name = shift; + + $self->{interfaces}->{$name} = { + methods => {}, + signals => {}, + props => {}, + } unless exists $self->{interfaces}->{$name}; +} + +=item my $bool = $ins->has_interface($name) + +Return a true value if the object is registered as providing +an interface with the name C<$name>; returns false otherwise. + +=cut + +sub has_interface { + my $self = shift; + my $name = shift; + + return exists $self->{interfaces}->{$name} ? 1 : 0; +} + +=item my @interfaces = $ins->has_method($name, [$interface]) + +Return a list of all interfaces provided by the object, which +contain a method called C<$name>. This may be an empty list. +The optional C<$interface> parameter can restrict the check to +just that one interface. + +=cut + +sub has_method { + my $self = shift; + my $name = shift; + + if (@_) { + my $interface = shift; + return () unless exists $self->{interfaces}->{$interface}; + return () unless exists $self->{interfaces}->{$interface}->{methods}->{$name}; + return ($interface); + } else { + my @interfaces; + foreach my $interface (keys %{$self->{interfaces}}) { + if (exists $self->{interfaces}->{$interface}->{methods}->{$name}) { + push @interfaces, $interface; + } + } + return @interfaces; + } +} + +=item my $boolean = $ins->is_method_allowed($name[, $interface]) + +Checks according to whether the remote caller is allowed to invoke +the method C<$name> on the object associated with this introspector. +If this object has 'strict exports' enabled, then only explicitly +exported methods will be allowed. The optional C<$interface> parameter +can restrict the check to just that one interface. Returns a non-zero +value if the method should be allowed. + +=cut + +sub is_method_allowed { + my $self = shift; + my $name = shift; + + if ($self->{strict}) { + return $self->has_method($name, @_) ? 1 : 0; + } else { + return 1; + } +} + +=item my @interfaces = $ins->has_signal($name) + +Return a list of all interfaces provided by the object, which +contain a signal called C<$name>. This may be an empty list. + +=cut + +sub has_signal { + my $self = shift; + my $name = shift; + + my @interfaces; + foreach my $interface (keys %{$self->{interfaces}}) { + if (exists $self->{interfaces}->{$interface}->{signals}->{$name}) { + push @interfaces, $interface; + } + } + return @interfaces; +} + +=item my @interfaces = $ins->has_property($name) + +Return a list of all interfaces provided by the object, which +contain a property called C<$name>. This may be an empty list. +The optional C<$interface> parameter can restrict the check to +just that one interface. + +=cut + +sub has_property { + my $self = shift; + my $name = shift; + + if (@_) { + my $interface = shift; + return () unless exists $self->{interfaces}->{$interface}; + return () unless exists $self->{interfaces}->{$interface}->{props}->{$name}; + return ($interface); + } else { + my @interfaces; + foreach my $interface (keys %{$self->{interfaces}}) { + if (exists $self->{interfaces}->{$interface}->{props}->{$name}) { + push @interfaces, $interface; + } + } + return @interfaces; + } +} + +=item $ins->add_method($name, $params, $returns, $interface, $attributes, $paramnames, $returnnames); + +Register the object as providing a method called C<$name> accepting parameters +whose types are declared by C<$params> and returning values whose type +are declared by C<$returns>. The method will be scoped to the inteface +named by C<$interface>. The C<$attributes> parameter is a hash reference +for annotating the method. The C<$paramnames> and C<$returnames> parameters +are a list of argument and return value names. + +=cut + +sub add_method { + my $self = shift; + my $name = shift; + my $params = shift; + my $returns = shift; + my $interface = shift; + my $attributes = shift; + my $paramnames = shift; + my $returnnames = shift; + + $self->add_interface($interface); + $self->{interfaces}->{$interface}->{methods}->{$name} = { + params => $params, + returns => $returns, + paramnames => $paramnames, + returnnames => $returnnames, + deprecated => $attributes->{deprecated} ? 1 : 0, + no_reply => $attributes->{no_return} ? 1 : 0, + }; +} + +=item $ins->add_signal($name, $params, $interface, $attributes); + +Register the object as providing a signal called C<$name> with parameters +whose types are declared by C<$params>. The signal will be scoped to the inteface +named by C<$interface>. The C<$attributes> parameter is a hash reference +for annotating the signal. + +=cut + +sub add_signal { + my $self = shift; + my $name = shift; + my $params = shift; + my $interface = shift; + my $attributes = shift; + my $paramnames = shift; + + $self->add_interface($interface); + $self->{interfaces}->{$interface}->{signals}->{$name} = { + params => $params, + paramnames => $paramnames, + deprecated => $attributes->{deprecated} ? 1 : 0, + }; +} + +=item $ins->add_property($name, $type, $access, $interface, $attributes); + +Register the object as providing a property called C<$name> with a type +of C<$type>. The C<$access> parameter can be one of C, C, +or C. The property will be scoped to the inteface +named by C<$interface>. The C<$attributes> parameter is a hash reference +for annotating the signal. + +=cut + +sub add_property { + my $self = shift; + my $name = shift; + my $type = shift; + my $access = shift; + my $interface = shift; + my $attributes = shift; + + $self->add_interface($interface); + $self->{interfaces}->{$interface}->{props}->{$name} = { + type => $type, + access => $access, + deprecated => $attributes->{deprecated} ? 1 : 0, + }; +} + +=item my $boolean = $ins->is_method_deprecated($name, $interface) + +Returns a true value if the method called C<$name> in the interface +C<$interface> is marked as deprecated + +=cut + +sub is_method_deprecated { + my $self = shift; + my $name = shift; + my $interface = shift; + + die "no interface $interface" unless exists $self->{interfaces}->{$interface}; + die "no method $name in interface $interface" unless exists $self->{interfaces}->{$interface}->{methods}->{$name}; + return 1 if $self->{interfaces}->{$interface}->{methods}->{$name}->{deprecated}; + return 0; +} + +=item my $boolean = $ins->is_signal_deprecated($name, $interface) + +Returns a true value if the signal called C<$name> in the interface +C<$interface> is marked as deprecated + +=cut + +sub is_signal_deprecated { + my $self = shift; + my $name = shift; + my $interface = shift; + + die "no interface $interface" unless exists $self->{interfaces}->{$interface}; + die "no signal $name in interface $interface" unless exists $self->{interfaces}->{$interface}->{signals}->{$name}; + return 1 if $self->{interfaces}->{$interface}->{signals}->{$name}->{deprecated}; + return 0; +} + +=item my $boolean = $ins->is_property_deprecated($name, $interface) + +Returns a true value if the property called C<$name> in the interface +C<$interface> is marked as deprecated + +=cut + +sub is_property_deprecated { + my $self = shift; + my $name = shift; + my $interface = shift; + + die "no interface $interface" unless exists $self->{interfaces}->{$interface}; + die "no property $name in interface $interface" unless exists $self->{interfaces}->{$interface}->{props}->{$name}; + return 1 if $self->{interfaces}->{$interface}->{props}->{$name}->{deprecated}; + return 0; +} + +=item my $boolean = $ins->does_method_reply($name, $interface) + +Returns a true value if the method called C<$name> in the interface +C<$interface> will generate a reply. Returns a false value otherwise. + +=cut + +sub does_method_reply { + my $self = shift; + my $name = shift; + my $interface = shift; + + die "no interface $interface" unless exists $self->{interfaces}->{$interface}; + die "no method $name in interface $interface" unless exists $self->{interfaces}->{$interface}->{methods}->{$name}; + return 0 if $self->{interfaces}->{$interface}->{methods}->{$name}->{no_reply}; + return 1; +} + +=item my @names = $ins->list_interfaces + +Returns a list of all interfaces registered as being provided +by the object. + +=cut + +sub list_interfaces { + my $self = shift; + + return keys %{$self->{interfaces}}; +} + +=item my @names = $ins->list_methods($interface) + +Returns a list of all methods registered as being provided +by the object, within the interface C<$interface>. + +=cut + +sub list_methods { + my $self = shift; + my $interface = shift; + return keys %{$self->{interfaces}->{$interface}->{methods}}; +} + +=item my @names = $ins->list_signals($interface) + +Returns a list of all signals registered as being provided +by the object, within the interface C<$interface>. + +=cut + +sub list_signals { + my $self = shift; + my $interface = shift; + return keys %{$self->{interfaces}->{$interface}->{signals}}; +} + +=item my @names = $ins->list_properties($interface) + +Returns a list of all properties registered as being provided +by the object, within the interface C<$interface>. + +=cut + +sub list_properties { + my $self = shift; + my $interface = shift; + return keys %{$self->{interfaces}->{$interface}->{props}}; +} + +=item my @paths = $self->list_children; + +Returns a list of object paths representing all the children +of this node. + +=cut + +sub list_children { + my $self = shift; + return @{$self->{children}}; +} + +=item my $path = $ins->get_object_path + +Returns the path of the object associated with this introspection +data + +=cut + +sub get_object_path { + my $self = shift; + return $self->{object_path}; +} + +=item my @types = $ins->get_method_params($interface, $name) + +Returns a list of declared data types for parameters of the +method called C<$name> within the interface C<$interface>. + +=cut + +sub get_method_params { + my $self = shift; + my $interface = shift; + my $method = shift; + return @{$self->{interfaces}->{$interface}->{methods}->{$method}->{params}}; +} + +=item my @types = $ins->get_method_param_names($interface, $name) + +Returns a list of declared names for parameters of the +method called C<$name> within the interface C<$interface>. + +=cut + +sub get_method_param_names { + my $self = shift; + my $interface = shift; + my $method = shift; + return @{$self->{interfaces}->{$interface}->{methods}->{$method}->{paramnames}}; +} + +=item my @types = $ins->get_method_returns($interface, $name) + +Returns a list of declared data types for return values of the +method called C<$name> within the interface C<$interface>. + +=cut + +sub get_method_returns { + my $self = shift; + my $interface = shift; + my $method = shift; + return @{$self->{interfaces}->{$interface}->{methods}->{$method}->{returns}}; +} + +=item my @types = $ins->get_method_return_names($interface, $name) + +Returns a list of declared names for return values of the +method called C<$name> within the interface C<$interface>. + +=cut + +sub get_method_return_names { + my $self = shift; + my $interface = shift; + my $method = shift; + return @{$self->{interfaces}->{$interface}->{methods}->{$method}->{returnnames}}; +} + +=item my @types = $ins->get_signal_params($interface, $name) + +Returns a list of declared data types for values associated with the +signal called C<$name> within the interface C<$interface>. + +=cut + +sub get_signal_params { + my $self = shift; + my $interface = shift; + my $signal = shift; + return @{$self->{interfaces}->{$interface}->{signals}->{$signal}->{params}}; +} + +=item my @types = $ins->get_signal_param_names($interface, $name) + +Returns a list of declared names for values associated with the +signal called C<$name> within the interface C<$interface>. + +=cut + +sub get_signal_param_names { + my $self = shift; + my $interface = shift; + my $signal = shift; + return @{$self->{interfaces}->{$interface}->{signals}->{$signal}->{paramnames}}; +} + +=item my $type = $ins->get_property_type($interface, $name) + +Returns the declared data type for property called C<$name> within +the interface C<$interface>. + +=cut + +sub get_property_type { + my $self = shift; + my $interface = shift; + my $prop = shift; + return $self->{interfaces}->{$interface}->{props}->{$prop}->{type}; +} + +=item my $bool = $ins->is_property_readable($interface, $name); + +Returns a true value if the property called C<$name> within the +interface C<$interface> can have its value read. + +=cut + +sub is_property_readable { + my $self = shift; + my $interface = shift; + my $prop = shift; + my $access = $self->{interfaces}->{$interface}->{props}->{$prop}->{access}; + return $access eq "readwrite" || $access eq "read" ? 1 : 0; +} + +=item my $bool = $ins->is_property_writable($interface, $name); + +Returns a true value if the property called C<$name> within the +interface C<$interface> can have its value written to. + +=cut + +sub is_property_writable { + my $self = shift; + my $interface = shift; + my $prop = shift; + my $access = $self->{interfaces}->{$interface}->{props}->{$prop}->{access}; + return $access eq "readwrite" || $access eq "write" ? 1 : 0; +} + +sub _parse { + my $self = shift; + my $xml = shift; + + my $twig = XML::Twig->new(); + $twig->parse($xml); + + $self->_parse_node($twig->root); +} + +sub _parse_node { + my $self = shift; + my $node = shift; + + $self->{object_path} = $node->att("name") if defined $node->att("name"); + die "no object path provided" unless defined $self->{object_path}; + $self->{children} = []; + foreach my $child ($node->children("interface")) { + $self->_parse_interface($child); + } + foreach my $child ($node->children("node")) { + if (!$child->has_children()) { + push @{$self->{children}}, $child->att("name"); + } else { + push @{$self->{children}}, $self->new(node => $child); + } + } +} + +sub _parse_interface { + my $self = shift; + my $node = shift; + + my $name = $node->att("name"); + $self->{interfaces}->{$name} = { + methods => {}, + signals => {}, + props => {}, + }; + + foreach my $child ($node->children("method")) { + $self->_parse_method($child, $name); + } + foreach my $child ($node->children("signal")) { + $self->_parse_signal($child, $name); + } + foreach my $child ($node->children("property")) { + $self->_parse_property($child, $name); + } +} + +sub _parse_method { + my $self = shift; + my $node = shift; + my $interface = shift; + + my $name = $node->att("name"); + my @params; + my @returns; + my @paramnames; + my @returnnames; + my $deprecated = 0; + my $no_reply = 0; + foreach my $child ($node->children("arg")) { + my $type = $child->att("type"); + my $direction = $child->att("direction"); + my $name = $child->att("name"); + + my @sig = split //, $type; + my @type = $self->_parse_type(\@sig); + if (!defined $direction || $direction eq "in") { + push @params, @type; + push @paramnames, $name; + } elsif ($direction eq "out") { + push @returns, @type; + push @returnnames, $name; + } + } + foreach my $child ($node->children("annotation")) { + my $name = $child->att("name"); + my $value = $child->att("value"); + + if ($name eq "org.freedesktop.DBus.Deprecated") { + $deprecated = 1 if lc($value) eq "true"; + } elsif ($name eq "org.freedesktop.DBus.Method.NoReply") { + $no_reply = 1 if lc($value) eq "true"; + } + } + + $self->{interfaces}->{$interface}->{methods}->{$name} = { + params => \@params, + returns => \@returns, + no_reply => $no_reply, + deprecated => $deprecated, + paramnames => \@paramnames, + returnnames => \@returnnames, + } +} + +sub _parse_type { + my $self = shift; + my $sig = shift; + + my $root = []; + my $current = $root; + my @cont; + while (my $type = shift @{$sig}) { + if (exists $simple_type_rev_map{ord($type)}) { + push @{$current}, $simple_type_rev_map{ord($type)}; + if ($current->[0] eq "array") { + $current = pop @cont; + } + } else { + if ($type eq "(") { + my $new = ["struct"]; + push @{$current}, $new; + push @cont, $current; + $current = $new; + } elsif ($type eq "a") { + my $new = ["array"]; + push @cont, $current; + push @{$current}, $new; + $current = $new; + } elsif ($type eq "{") { + if ($current->[0] ne "array") { + die "dict must only occur within an array"; + } + $current->[0] = "dict"; + } elsif ($type eq ")") { + die "unexpected end of struct" unless + $current->[0] eq "struct"; + $current = pop @cont; + if ($current->[0] eq "array") { + $current = pop @cont; + } + } elsif ($type eq "}") { + die "unexpected end of dict" unless + $current->[0] eq "dict"; + $current = pop @cont; + if ($current->[0] eq "array") { + $current = pop @cont; + } + } elsif ($type eq "v") { + push @{$current}, ["variant"]; + if ($current->[0] eq "array") { + $current = pop @cont; + } + } else { + die "unknown type sig '$type'"; + } + } + } + return @{$root}; +} + +sub _parse_signal { + my $self = shift; + my $node = shift; + my $interface = shift; + + my $name = $node->att("name"); + my @params; + my @paramnames; + my $deprecated = 0; + foreach my $child ($node->children("arg")) { + my $type = $child->att("type"); + my $name = $child->att("name"); + my @sig = split //, $type; + my @type = $self->_parse_type(\@sig); + push @params, @type; + push @paramnames, $name; + } + foreach my $child ($node->children("annotation")) { + my $name = $child->att("name"); + my $value = $child->att("value"); + + if ($name eq "org.freedesktop.DBus.Deprecated") { + $deprecated = 1 if lc($value) eq "true"; + } + } + + $self->{interfaces}->{$interface}->{signals}->{$name} = { + params => \@params, + paramnames => \@paramnames, + deprecated => $deprecated, + }; +} + +sub _parse_property { + my $self = shift; + my $node = shift; + my $interface = shift; + + my $name = $node->att("name"); + my $access = $node->att("access"); + my $deprecated = 0; + + foreach my $child ($node->children("annotation")) { + my $name = $child->att("name"); + my $value = $child->att("value"); + + if ($name eq "org.freedesktop.DBus.Deprecated") { + $deprecated = 1 if lc($value) eq "true"; + } + } + my @sig = split //, $node->att("type"); + $self->{interfaces}->{$interface}->{props}->{$name} = { + type => $self->_parse_type(\@sig), + access => $access, + deprecated => $deprecated, + }; +} + +=item my $xml = $ins->format([$obj]) + +Return a string containing an XML document representing the +state of the introspection data. The optional C<$obj> parameter +can be an instance of L to include object +specific information in the XML (eg child nodes). + +=cut + +sub format { + my $self = shift; + my $obj = shift; + + my $xml = '' . "\n"; + + return $xml . $self->to_xml("", $obj); +} + +=item my $xml_fragment = $ins->to_xml + +Returns a string containing an XML fragment representing the +state of the introspection data. This is basically the same +as the C method, but without the leading doctype +declaration. + +=cut + +sub to_xml { + my $self = shift; + my $indent = shift; + my $obj = shift; + + my $xml = ''; + my $path = $obj ? $obj->get_object_path : $self->{object_path}; + unless (defined $path) { + die "no object_path for introspector, and no object supplied"; + } + $xml .= $indent . '' . "\n"; + + foreach my $name (sort { $a cmp $b } keys %{$self->{interfaces}}) { + my $interface = $self->{interfaces}->{$name}; + $xml .= $indent . ' ' . "\n"; + foreach my $mname (sort { $a cmp $b } keys %{$interface->{methods}}) { + my $method = $interface->{methods}->{$mname}; + $xml .= $indent . ' ' . "\n"; + + my @paramnames = map{ $_ ? "name=\"$_\" " : '' } ( @{$method->{paramnames}} ); + my @returnnames = map{ $_ ? "name=\"$_\" " : '' } ( @{$method->{returnnames}} ); + + foreach my $type (@{$method->{params}}) { + next if ! ref($type) && exists $magic_type_map{$type}; + $xml .= $indent . ' ' . "\n"; + } + + foreach my $type (@{$method->{returns}}) { + next if ! ref($type) && exists $magic_type_map{$type}; + $xml .= $indent . ' ' . "\n"; + } + if ($method->{deprecated}) { + $xml .= $indent . ' ' . "\n"; + } + if ($method->{no_reply}) { + $xml .= $indent . ' ' . "\n"; + } + $xml .= $indent . ' ' . "\n"; + } + foreach my $sname (sort { $a cmp $b } keys %{$interface->{signals}}) { + my $signal = $interface->{signals}->{$sname}; + $xml .= $indent . ' ' . "\n"; + + my @paramnames = map{ $_ ? "name=\"$_\" " : '' } ( @{$signal->{paramnames}} ); + + foreach my $type (@{$signal->{params}}) { + next if ! ref($type) && exists $magic_type_map{$type}; + $xml .= $indent . ' ' . "\n"; + } + if ($signal->{deprecated}) { + $xml .= $indent . ' ' . "\n"; + } + $xml .= $indent . ' ' . "\n"; + } + + foreach my $pname (sort { $a cmp $b } keys %{$interface->{props}}) { + my $prop = $interface->{props}->{$pname}; + my $type = $interface->{props}->{$pname}->{type}; + my $access = $interface->{props}->{$pname}->{access}; + if ($prop->{deprecated}) { + $xml .= $indent . ' ' . "\n"; + $xml .= $indent . ' ' . "\n"; + $xml .= $indent . ' ' . "\n"; + } else { + $xml .= $indent . ' ' . "\n"; + } + } + + $xml .= $indent . ' ' . "\n"; + } + + # + # Interfaces don't have children, objects do + # + if ($obj) { + foreach ( $obj->_get_sub_nodes ) { + $xml .= $indent . ' ' . "\n"; + } + } else { + foreach my $child (@{$self->{children}}) { + if (ref($child) eq __PACKAGE__) { + $xml .= $child->to_xml($indent . " "); + } else { + $xml .= $indent . ' ' . "\n"; + } + } + } + + $xml .= $indent . "\n"; +} + +=item $type = $ins->to_xml_type($type) + +Takes a text-based representation of a data type and returns +the compact representation used in XML introspection data. + +=cut + +sub to_xml_type { + my $self = shift; + my $type = shift; + + my $sig = ''; + if (ref($type) eq "ARRAY") { + if ($type->[0] eq "array") { + if ($#{$type} != 1) { + die "array spec must contain only 1 type"; + } + $sig .= chr($compound_type_map{$type->[0]}); + $sig .= $self->to_xml_type($type->[1]); + } elsif ($type->[0] eq "struct") { + $sig .= "("; + for (my $i = 1 ; $i <= $#{$type} ; $i++) { + $sig .= $self->to_xml_type($type->[$i]); + } + $sig .= ")"; + } elsif ($type->[0] eq "dict") { + if ($#{$type} != 2) { + die "dict spec must contain only 2 types"; + } + $sig .= chr($compound_type_map{"array"}); + $sig .= "{"; + $sig .= $self->to_xml_type($type->[1]); + $sig .= $self->to_xml_type($type->[2]); + $sig .= "}"; + } elsif ($type->[0] eq "variant") { + if ($#{$type} != 0) { + die "dict spec must contain no sub-types"; + } + $sig .= chr($compound_type_map{"variant"}); + } else { + die "unknown/unsupported compound type " . $type->[0] . " expecting 'array', 'struct', or 'dict'"; + } + } else { + die "unknown/unsupported scalar type '$type'" + unless exists $simple_type_map{$type}; + $sig .= chr($simple_type_map{$type}); + } + return $sig; +} + +=item $ins->encode($message, $type, $name, $direction, @args) + +Append a set of values <@args> to a message object C<$message>. +The C<$type> parameter is either C or C and +C<$direction> is either C or C. The introspection +data will be queried to obtain the declared data types & the +argument marshalling accordingly. + +=cut + +sub encode { + my $self = shift; + my $message = shift; + my $type = shift; + my $name = shift; + my $direction = shift; + my @args = @_; + + my $interface = $message->get_interface; + + my @types; + if ($interface) { + if (exists $self->{interfaces}->{$interface}) { + if (exists $self->{interfaces}->{$interface}->{$type}->{$name}) { + @types = @{$self->{interfaces}->{$interface}->{$type}->{$name}->{$direction}}; + } else { + warn "missing introspection data when encoding $type '$name' in object " . + $self->get_object_path . "\n" if $debug; + } + } else { + warn "missing interface '$interface' in introspection data for object '" . + $self->get_object_path . "' encoding $type '$name'\n" if $debug; + } + } else { + foreach my $in (keys %{$self->{interfaces}}) { + if (exists $self->{interfaces}->{$in}->{$type}->{$name}) { + $interface = $in; + } + } + if ($interface) { + @types = @{$self->{interfaces}->{$interface}->{$type}->{$name}->{$direction}}; + } else { + warn "no interface in introspection data for object " . + $self->get_object_path . " encoding $type '$name'\n" if $debug; + } + } + + # If you don't explicitly 'return ()' from methods, Perl + # will always return a single element representing the + # return value of the last command executed in the method. + # To avoid this causing a PITA for methods exported with + # no return values, we throw away returns instead of dieing + if ($direction eq "returns" && + $#types == -1 && + $#args != -1) { + @args = (); + } + + # No introspection data available, then just fallback + # to a plain (guess types) append + unless (@types) { + $message->append_args_list(@args); + return; + } + + + die "expected " . int(@types) . " $direction, but got " . int(@args) + unless $#types == $#args; + + my $iter = $message->iterator(1); + foreach my $t ($self->_convert(@types)) { + $iter->append(shift @args, $t); + } +} + +sub _convert { + my $self = shift; + my @in = @_; + + my @out; + foreach my $in (@in) { + if (ref($in) eq "ARRAY") { + my @subtype = @{$in}; + shift @subtype; + my @subout = $self->_convert(@subtype); + die "unknown compound type " . $in->[0] unless + exists $compound_type_map{lc $in->[0]}; + + push @out, [$compound_type_map{lc $in->[0]}, \@subout]; + } elsif (exists $magic_type_map{lc $in}) { + push @out, $magic_type_map{lc $in}; + } else { + die "unknown simple type " . $in unless + exists $simple_type_map{lc $in}; + push @out, $simple_type_map{lc $in}; + } + } + return @out; +} + +=item my @args = $ins->decode($message, $type, $name, $direction) + +Unmarshalls the contents of a message object C<$message>. +The C<$type> parameter is either C or C and +C<$direction> is either C or C. The introspection +data will be queried to obtain the declared data types & the +arguments unmarshalled accordingly. + +=cut + +sub decode { + my $self = shift; + my $message = shift; + my $type = shift; + my $name = shift; + my $direction = shift; + + my $interface = $message->get_interface; + + my @types; + if ($interface) { + if (exists $self->{interfaces}->{$interface}) { + if (exists $self->{interfaces}->{$interface}->{$type}->{$name}) { + @types = + @{$self->{interfaces}->{$interface}->{$type}->{$name}->{$direction}}; + } else { + warn "missing introspection data when decoding $type '$name' in object " . + $self->get_object_path . "\n" if $debug; + } + } else { + warn "missing interface '$interface' in introspection data for object '" . + $self->get_object_path . "' when decoding $type '$name'\n" if $debug; + } + } else { + foreach my $in (keys %{$self->{interfaces}}) { + if (exists $self->{interfaces}->{$in}->{$type}->{$name}) { + $interface = $in; + } + } + if (!$interface) { + warn "no interface in introspection data for object " . + $self->get_object_path . " decoding $type '$name'\n" if $debug; + } else { + @types = + @{$self->{interfaces}->{$interface}->{$type}->{$name}->{$direction}}; + } + } + + # If there are no types defined, just return the + # actual data from the message, assuming the introspection + # data was partial. + return $message->get_args_list + unless @types; + + my $iter = $message->iterator; + + my $hasnext = 1; + my @rawtypes = $self->_convert(@types); + my @ret; + while (@types) { + my $type = shift @types; + my $rawtype = shift @rawtypes; + + if (exists $magic_type_map{$type}) { + push @ret, &$rawtype($message); + } elsif ($hasnext) { + push @ret, $iter->get($rawtype); + $hasnext = $iter->next; + } + } + return @ret; +} + +1; + +=pod + +=back + +=head1 AUTHOR + +Daniel P. Berrange + +=head1 COPYRIGHT + +Copyright (C) 2004-2011 Daniel P. Berrange + +=head1 SEE ALSO + +L, L + +=cut diff --git a/lib/Net/DBus/Binding/Iterator.pm b/lib/Net/DBus/Binding/Iterator.pm new file mode 100644 index 0000000..6d5fdac --- /dev/null +++ b/lib/Net/DBus/Binding/Iterator.pm @@ -0,0 +1,715 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Binding::Iterator - Reading and writing message parameters + +=head1 SYNOPSIS + +Creating a new message + + my $msg = new Net::DBus::Binding::Message::Signal; + my $iterator = $msg->iterator; + + $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 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 + +package Net::DBus::Binding::Iterator; + + +use 5.006; +use strict; +use warnings; + +use Net::DBus; + +=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_object_path() + +=item $iter->append_object_path($val); + +Read or write a UTF-8 string value, whose contents is +a valid object path, from/to the message iterator + +=item my $val = $iter->get_signature() + +=item $iter->append_signature($val); + +Read or write a UTF-8 string, whose contents is a +valid type signature, value from/to the message iterator + +=item my $val = $iter->get_int16() + +=item $iter->append_int16($val); + +Read or write a signed 16 bit value from/to the +message iterator + +=item my $val = $iter->get_uint16() + +=item $iter->append_uint16($val); + +Read or write an unsigned 16 bit value from/to the +message iterator + +=item my $val = $iter->get_int32() + +=item $iter->append_int32($val); + +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. An error will be raised if this +build of Perl does not support 64 bit integers + +=item my $val = $iter->get_uint64() + +=item $iter->append_uint64($val); + +Read or write an unsigned 64 bit value from/to the +message iterator. An error will be raised if this +build of Perl does not support 64 bit integers + +=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; + return $self->_get_int64; +} + +sub get_uint64 { + my $self = shift; + return $self->_get_uint64; +} + +sub append_int64 { + my $self = shift; + $self->_append_int64(shift); +} + +sub append_uint64 { + my $self = shift; + $self->_append_uint64(shift); +} + +=item my $value = $iter->get() + +=item my $value = $iter->get($type); + +Get the current value pointed to by this iterator. If the optional +C<$type> parameter is supplied, the wire type will be compared with +the desired type & a warning output if their differ. The C<$type> +value must be one of the C +constants. + +=cut + +sub get { + my $self = shift; + my $type = shift; + + if (defined $type) { + if (ref($type)) { + if (ref($type) eq "ARRAY") { + # XXX we should recursively validate types + $type = $type->[0]; + if ($type eq &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { + $type = &Net::DBus::Binding::Message::TYPE_ARRAY; + } + } else { + die "unsupport type reference $type"; + } + } + + my $actual = $self->get_arg_type; + if ($actual != $type) { + # "Be strict in what you send, be leniant in what you accept" + # - ie can't rely on python to send correct types, eg int32 vs uint32 + # But, don't complain for variants because a number of apps (eg HAL) + # claim to return variants, but in fact don't correctly encode their + # data as variants. Technically a bug in the server, but it does + # 'just work' normally. + warn "requested type '" . chr($type) . "' ($type) did not match wire type '" . chr($actual) . "' ($actual)" + if $type != &Net::DBus::Binding::Message::TYPE_VARIANT; + + $type = $actual; + } + } else { + $type = $self->get_arg_type; + } + + if ($type == &Net::DBus::Binding::Message::TYPE_STRING) { + return $self->get_string; + } elsif ($type == &Net::DBus::Binding::Message::TYPE_BOOLEAN) { + return $self->get_boolean; + } elsif ($type == &Net::DBus::Binding::Message::TYPE_BYTE) { + return $self->get_byte; + } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT16) { + return $self->get_int16; + } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT16) { + return $self->get_uint16; + } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT32) { + return $self->get_int32; + } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT32) { + return $self->get_uint32; + } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT64) { + return $self->get_int64; + } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT64) { + return $self->get_uint64; + } elsif ($type == &Net::DBus::Binding::Message::TYPE_DOUBLE) { + return $self->get_double; + } elsif ($type == &Net::DBus::Binding::Message::TYPE_ARRAY) { + my $array_type = $self->get_element_type(); + if ($array_type == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { + return $self->get_dict(); + } else { + return $self->get_array($array_type); + } + } elsif ($type == &Net::DBus::Binding::Message::TYPE_STRUCT) { + return $self->get_struct(); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_VARIANT) { + return $self->get_variant(); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { + die "dictionary can only occur as part of an array type"; + } elsif ($type == &Net::DBus::Binding::Message::TYPE_INVALID) { + die "cannot handle Net::DBus::Binding::Message::TYPE_INVALID"; + } elsif ($type == &Net::DBus::Binding::Message::TYPE_OBJECT_PATH) { + return $self->get_object_path(); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_SIGNATURE) { + return $self->get_signature(); + } else { + die "unknown argument type '" . chr($type) . "' ($type)"; + } +} + +=item my $hashref = $iter->get_dict() + +If the iterator currently points to a dictionary value, unmarshalls +and returns the value as a hash reference. + +=cut + +sub get_dict { + my $self = shift; + + my $iter = $self->_recurse(); + my $type = $iter->get_arg_type(); + my $dict = {}; + while ($type == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { + my $entry = $iter->get_struct(); + if ($#{$entry} != 1) { + die "Dictionary entries must be structs of 2 elements. This entry has " . ($#{$entry}+1) ." elements"; + } + + $dict->{$entry->[0]} = $entry->[1]; + $iter->next(); + $type = $iter->get_arg_type(); + } + return $dict; +} + +=item my $hashref = $iter->get_array() + +If the iterator currently points to an array value, unmarshalls +and returns the value as a array reference. + +=cut + +sub get_array { + my $self = shift; + my $array_type = shift; + + my $iter = $self->_recurse(); + my $type = $iter->get_arg_type(); + my $array = []; + while ($type != &Net::DBus::Binding::Message::TYPE_INVALID) { + if ($type != $array_type) { + die "Element $type not of array type $array_type"; + } + + my $value = $iter->get($type); + push @{$array}, $value; + $iter->next(); + $type = $iter->get_arg_type(); + } + return $array; +} + +=item my $hashref = $iter->get_variant() + +If the iterator currently points to a variant value, unmarshalls +and returns the value contained in the variant. + +=cut + +sub get_variant { + my $self = shift; + + my $iter = $self->_recurse(); + return $iter->get(); +} + + +=item my $hashref = $iter->get_struct() + +If the iterator currently points to an struct value, unmarshalls +and returns the value as a array reference. The values in the array +correspond to members of the struct. + +=cut + +sub get_struct { + my $self = shift; + + my $iter = $self->_recurse(); + my $type = $iter->get_arg_type(); + my $struct = []; + while ($type != &Net::DBus::Binding::Message::TYPE_INVALID) { + my $value = $iter->get($type); + push @{$struct}, $value; + $iter->next(); + $type = $iter->get_arg_type(); + } + return $struct; +} + +=item $iter->append($value) + +=item $iter->append($value, $type) + +Appends a value to the message associated with this iterator. The +value is marshalled into wire format, according to the following +rules. + +If the C<$value> is an instance of L, +the embedded data type is used. + +If the C<$type> parameter is supplied, that is taken to represent +the data type. The type must be one of the C +constants. + +Otherwise, the data type is chosen to be a string, dict or array +according to the perl data types SCALAR, HASH or ARRAY. + +=cut + +sub append { + my $self = shift; + my $value = shift; + my $type = shift; + + if (ref($value) eq "Net::DBus::Binding::Value" && + ((! defined ref($type)) || + (ref($type) ne "ARRAY") || + $type->[0] != &Net::DBus::Binding::Message::TYPE_VARIANT)) { + $type = $value->type; + $value = $value->value; + } + + if (!defined $type) { + $type = $self->guess_type($value); + } + + if (ref($type) eq "ARRAY") { + my $maintype = $type->[0]; + my $subtype = $type->[1]; + + if ($maintype == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { + $self->append_dict($value, $subtype); + } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_STRUCT) { + $self->append_struct($value, $subtype); + } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_ARRAY) { + $self->append_array($value, $subtype); + } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_VARIANT) { + $self->append_variant($value, $subtype); + } else { + die "Unsupported compound type ", $maintype, " ('", chr($maintype), "')"; + } + } else { + # XXX is this good idea or not + $value = '' unless defined $value; + + if ($type == &Net::DBus::Binding::Message::TYPE_BOOLEAN) { + $self->append_boolean($value); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_BYTE) { + $self->append_byte($value); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_STRING) { + $self->append_string($value); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT16) { + $self->append_int16($value); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT16) { + $self->append_uint16($value); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT32) { + $self->append_int32($value); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT32) { + $self->append_uint32($value); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT64) { + $self->append_int64($value); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT64) { + $self->append_uint64($value); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_DOUBLE) { + $self->append_double($value); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_OBJECT_PATH) { + $self->append_object_path($value); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_SIGNATURE) { + $self->append_signature($value); + } else { + die "Unsupported scalar type ", $type, " ('", chr($type), "')"; + } + } +} + + +=item my $type = $iter->guess_type($value) + +Make a best guess at the on the wire data type to use for +marshalling C<$value>. If the value is a hash reference, +the dictionary type is returned; if the value is an array +reference the array type is returned; otherwise the string +type is returned. + +=cut + +sub guess_type { + my $self = shift; + my $value = shift; + + if (ref($value)) { + if (UNIVERSAL::isa($value, "Net::DBus::Binding::Value")) { + my $type = $value->type; + if (ref($type) && ref($type) eq "ARRAY") { + my $maintype = $type->[0]; + my $subtype = $type->[1]; + + if (!defined $subtype) { + if ($maintype == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { + $subtype = [ $self->guess_type(($value->value())[0]->[0]), + $self->guess_type(($value->value())[0]->[1]) ]; + } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_ARRAY) { + $subtype = [ $self->guess_type(($value->value())[0]->[0]) ]; + } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_STRUCT) { + $subtype = [ map { $self->guess_type($_) } @{($value->value())[0]} ]; + } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_VARIANT) { + $subtype = $self->guess_type($value->value); + } else { + die "Unguessable compound type '$maintype' ('", chr($maintype), "')\n"; + } + } + return [$maintype, $subtype]; + } else { + return $type; + } + } elsif (ref($value) eq "HASH") { + my $key = (keys %{$value})[0]; + my $val = $value->{$key}; + # XXX Basically impossible to decide between DICT & STRUCT + return [ &Net::DBus::Binding::Message::TYPE_DICT_ENTRY, + [ &Net::DBus::Binding::Message::TYPE_STRING, $self->guess_type($val)] ]; + } elsif (ref($value) eq "ARRAY") { + return [ &Net::DBus::Binding::Message::TYPE_ARRAY, + [$self->guess_type($value->[0])] ]; + } else { + die "cannot marshall reference of type " . ref($value); + } + } else { + # XXX Should we bother trying to guess integer & floating point types ? + # I say sod it, because strongly typed languages will support introspection + # and loosely typed languages won't care about the difference + return &Net::DBus::Binding::Message::TYPE_STRING; + } +} + +=item my $sig = $iter->format_signature($type) + +Given a data type representation, construct a corresponding +signature string + +=cut + +sub format_signature { + my $self = shift; + my $type = shift; + my ($sig, $t, $i); + + $sig = ""; + $i = 0; + + if (ref($type) eq "ARRAY") { + while ($i <= $#{$type}) { + $t = $$type[$i]; + + if (ref($t) eq "ARRAY") { + $sig .= $self->format_signature($t); + } elsif ($t == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { + $sig .= chr (&Net::DBus::Binding::Message::TYPE_ARRAY); + $sig .= "{" . $self->format_signature($$type[++$i]) . "}"; + } elsif ($t == &Net::DBus::Binding::Message::TYPE_STRUCT) { + $sig .= "(" . $self->format_signature($$type[++$i]) . ")"; + } else { + $sig .= chr($t); + } + + $i++; + } + } else { + $sig .= chr ($type); + } + + return $sig; +} + +=item $iter->append_array($value, $type) + +Append an array of values to the message. The C<$value> parameter +must be an array reference, whose elements all have the same data +type specified by the C<$type> parameter. + +=cut + +sub append_array { + my $self = shift; + my $array = shift; + my $type = shift; + + if (!defined($type)) { + $type = [$self->guess_type($array->[0])]; + } + + die "array must only have one type" + if $#{$type} > 0; + + my $sig = $self->format_signature($type); + my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_ARRAY, $sig); + + foreach my $value (@{$array}) { + $iter->append($value, $type->[0]); + } + + $self->_close_container($iter); +} + + +=item $iter->append_struct($value, $type) + +Append a struct to the message. The C<$value> parameter +must be an array reference, whose elements correspond to +members of the structure. The C<$type> parameter encodes +the type of each member of the struct. + +=cut + +sub append_struct { + my $self = shift; + my $struct = shift; + my $type = shift; + + if (defined($type) && + $#{$struct} != $#{$type}) { + die "number of values does not match type"; + } + + my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_STRUCT, ""); + + my @type = defined $type ? @{$type} : (); + foreach my $value (@{$struct}) { + $iter->append($value, shift @type); + } + + $self->_close_container($iter); +} + +=item $iter->append_dict($value, $type) + +Append a dictionary to the message. The C<$value> parameter +must be an hash reference.The C<$type> parameter encodes +the type of the key and value of the hash. + +=cut + +sub append_dict { + my $self = shift; + my $hash = shift; + my $type = shift; + + my $sig; + + $sig = "{"; + $sig .= $self->format_signature($type); + $sig .= "}"; + + my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_ARRAY, $sig); + + foreach my $key (keys %{$hash}) { + my $value = $hash->{$key}; + my $entry = $iter->_open_container(&Net::DBus::Binding::Message::TYPE_DICT_ENTRY, ""); + + $entry->append($key, $type->[0]); + $entry->append($value, $type->[1]); + $iter->_close_container($entry); + } + $self->_close_container($iter); +} + +=item $iter->append_variant($value) + +Append a value to the message, encoded as a variant type. The +C<$value> can be of any type, however, the variant will be +encoded as either a string, dictionary or array according to +the rules of the C method. + +=cut + +sub append_variant { + my $self = shift; + my $value = shift; + my $type = shift; + + if (UNIVERSAL::isa($value, "Net::DBus::Binding::Value")) { + $type = [$self->guess_type($value)]; + $value = $value->value; + } elsif (!defined $type || !defined $type->[0]) { + $type = [$self->guess_type($value)]; + } + die "variant must only have one type" + if defined $type && $#{$type} > 0; + + my $sig = $self->format_signature($type->[0]); + my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_VARIANT, $sig); + $iter->append($value, $type->[0]); + $self->_close_container($iter); +} + + +=item my $type = $iter->get_arg_type + +Retrieves the type code of the value pointing to by this iterator. +The returned code will correspond to one of the constants +C + +=item my $type = $iter->get_element_type + +If the iterator points to an array, retrieves the type code of +array elements. The returned code will correspond to one of the +constants C + +=cut + +1; + +=pod + +=back + +=head1 AUTHOR + +Daniel P. Berrange + +=head1 COPYRIGHT + +Copyright (C) 2004-2011 Daniel P. Berrange + +=head1 SEE ALSO + +L + +=cut diff --git a/lib/Net/DBus/Binding/Message.pm b/lib/Net/DBus/Binding/Message.pm new file mode 100644 index 0000000..2c12a16 --- /dev/null +++ b/lib/Net/DBus/Binding/Message.pm @@ -0,0 +1,462 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Binding::Message - Base class for messages + +=head1 SYNOPSIS + +Sending a message + + my $msg = new Net::DBus::Binding::Message::Signal; + my $iterator = $msg->iterator; + + $iterator->append_byte(132); + $iterator->append_int32(14241); + + $connection->send($msg); + +=head1 DESCRIPTION + +Provides a base class for the different kinds of +message that can be sent/received. Instances of +this class are never instantiated directly, rather +one of the four sub-types L, +L, L, +L should be used. + +=head1 CONSTANTS + +The following constants are defined in this module. They are +not exported into the caller's namespace & thus must be referenced +with their fully qualified package names + +=over 4 + +=item TYPE_ARRAY + +Constant representing the signature value associated with the +array data type. + +=item TYPE_BOOLEAN + +Constant representing the signature value associated with the +boolean data type. + +=item TYPE_BYTE + +Constant representing the signature value associated with the +byte data type. + +=item TYPE_DICT_ENTRY + +Constant representing the signature value associated with the +dictionary entry data type. + +=item TYPE_DOUBLE + +Constant representing the signature value associated with the +IEEE double precision floating point data type. + +=item TYPE_INT16 + +Constant representing the signature value associated with the +signed 16 bit integer data type. + +=item TYPE_INT32 + +Constant representing the signature value associated with the +signed 32 bit integer data type. + +=item TYPE_INT64 + +Constant representing the signature value associated with the +signed 64 bit integer data type. + +=item TYPE_OBJECT_PATH + +Constant representing the signature value associated with the +object path data type. + +=item TYPE_STRING + +Constant representing the signature value associated with the +UTF-8 string data type. + +=item TYPE_SIGNATURE + +Constant representing the signature value associated with the +signature data type. + +=item TYPE_STRUCT + +Constant representing the signature value associated with the +struct data type. + +=item TYPE_UINT16 + +Constant representing the signature value associated with the +unsigned 16 bit integer data type. + +=item TYPE_UINT32 + +Constant representing the signature value associated with the +unsigned 32 bit integer data type. + +=item TYPE_UINT64 + +Constant representing the signature value associated with the +unsigned 64 bit integer data type. + +=item TYPE_VARIANT + +Constant representing the signature value associated with the +variant data type. + +=back + +=head1 METHODS + +=over 4 + +=cut + +package Net::DBus::Binding::Message; + +use 5.006; +use strict; +use warnings; + +use Net::DBus::Binding::Iterator; +use Net::DBus::Binding::Message::Signal; +use Net::DBus::Binding::Message::MethodCall; +use Net::DBus::Binding::Message::MethodReturn; +use Net::DBus::Binding::Message::Error; + +=item my $msg = Net::DBus::Binding::Message->new(message => $rawmessage); + +Creates a new message object, initializing it with the underlying C +message object given by the C object. This constructor is +intended for internal use only, instead refer to one of the four +sub-types for this class for specific message types + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my %params = @_; + my $self = {}; + + $self->{message} = exists $params{message} ? $params{message} : + (Net::DBus::Binding::Message::_create(exists $params{type} ? $params{type} : die "type parameter is required")); + + bless $self, $class; + + if ($class eq "Net::DBus::Binding::Message") { + $self->_specialize; + } + + return $self; +} + +sub _specialize { + my $self = shift; + + my $type = $self->get_type; + if ($type == &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_CALL) { + bless $self, "Net::DBus::Binding::Message::MethodCall"; + } elsif ($type == &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN) { + bless $self, "Net::DBus::Binding::Message::MethodReturn"; + } elsif ($type == &Net::DBus::Binding::Message::MESSAGE_TYPE_ERROR) { + bless $self, "Net::DBus::Binding::Message::Error"; + } elsif ($type == &Net::DBus::Binding::Message::MESSAGE_TYPE_SIGNAL) { + bless $self, "Net::DBus::Binding::Message::Signal"; + } else { + warn "Unknown message type $type\n"; + } +} + +=item my $type = $msg->get_type + +Retrieves the type code for this message. The returned value corresponds +to one of the four C constants. + +=cut + +sub get_type { + my $self = shift; + + return $self->{message}->dbus_message_get_type; +} + +=item my $interface = $msg->get_interface + +Retrieves the name of the interface targetted by this message, possibly +an empty string if there is no applicable interface for this message. + +=cut + +sub get_interface { + my $self = shift; + + return $self->{message}->dbus_message_get_interface; +} + +=item my $path = $msg->get_path + +Retrieves the object path associated with the message, possibly an +empty string if there is no applicable object for this message. + +=cut + +sub get_path { + my $self = shift; + + return $self->{message}->dbus_message_get_path; +} + +=item my $name = $msg->get_destination + +Retrieves the uniqe or well-known bus name for client intended to be +the recipient of the message. Possibly returns an empty string if +the message is being broadcast to all clients. + +=cut + +sub get_destination { + my $self = shift; + + return $self->{message}->dbus_message_get_destination; +} + +=item my $name = $msg->get_sender + +Retireves the unique name of the client sending the message + +=cut + +sub get_sender { + my $self = shift; + + return $self->{message}->dbus_message_get_sender; +} + +=item my $serial = $msg->get_serial + +Retrieves the unique serial number of this message. The number +is guarenteed unique for as long as the connection over which +the message was sent remains open. May return zero, if the message +is yet to be sent. + +=cut + +sub get_serial { + my $self = shift; + + return $self->{message}->dbus_message_get_serial; +} + +=item my $name = $msg->get_member + +For method calls, retrieves the name of the method to be invoked, +while for signals, retrieves the name of the signal. + +=cut + +sub get_member { + my $self = shift; + + return $self->{message}->dbus_message_get_member; +} + +=item my $sig = $msg->get_signature + +Retrieves a string representing the type signature of the values +packed into the body of the message. + +=cut + +sub get_signature { + my $self = shift; + + return $self->{message}->dbus_message_get_signature; +} + +=item $msg->set_sender($name) + +Set the name of the client sending the message. The name must +be the unique name of the client. + +=cut + +sub set_sender { + my $self = shift; + $self->{message}->dbus_message_set_sender(@_); +} + +=item $msg->set_destination($name) + +Set the name of the intended recipient of the message. This is +typically used for signals to switch them from broadcast to +unicast. + +=cut + +sub set_destination { + my $self = shift; + $self->{message}->dbus_message_set_destination(@_); +} + +=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 class. + +=cut + +sub iterator { + my $self = shift; + my $append = @_ ? shift : 0; + + if ($append) { + return Net::DBus::Binding::Message::_iterator_append($self->{message}); + } else { + return Net::DBus::Binding::Message::_iterator($self->{message}); + } +} + +=item $boolean = $msg->get_no_reply() + +Gets the flag indicating whether the message is expecting +a reply to be sent. + +=cut + +sub get_no_reply { + my $self = shift; + + return $self->{message}->dbus_message_get_no_reply; +} + +=item $msg->set_no_reply($boolean) + +Toggles the flag indicating whether the message is expecting +a reply to be sent. All method call messages expect a reply +by default. By toggling this flag the communication latency +is reduced by removing the need for the client to wait + +=cut + + +sub set_no_reply { + my $self = shift; + my $flag = shift; + + $self->{message}->dbus_message_set_no_reply($flag); +} + +=item my @values = $msg->get_args_list + +De-marshall all the values in the body of the message, using the +message signature to identify data types. The values are returned +as a list. + +=cut + +sub get_args_list { + my $self = shift; + + my @ret; + my $iter = $self->iterator; + if ($iter->get_arg_type() != &Net::DBus::Binding::Message::TYPE_INVALID) { + do { + push @ret, $iter->get(); + } while ($iter->next); + } + + return @ret; +} + +=item $msg->append_args_list(@values) + +Append a set of values to the body of the message. Values will +be encoded as either a string, list or dictionary as appropriate +to their Perl data type. For more specific data typing needs, +the L object should be used instead. + +=cut + +sub append_args_list { + my $self = shift; + my @args = @_; + + my $iter = $self->iterator(1); + foreach my $arg (@args) { + $iter->append($arg); + } +} + +# To keep autoloader quiet +sub DESTROY { +} + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. + + my $constname; + our $AUTOLOAD; + ($constname = $AUTOLOAD) =~ s/.*:://; + + die "&Net::DBus::Binding::Message::constant not defined" if $constname eq '_constant'; + + if (!exists $Net::DBus::Binding::Message::_constants{$constname}) { + die "no such constant \$Net::DBus::Binding::Message::$constname"; + } + + { + no strict 'refs'; + *$AUTOLOAD = sub { $Net::DBus::Binding::Message::_constants{$constname} }; + } + goto &$AUTOLOAD; +} + +1; + +=pod + +=back + +=head1 AUTHOR + +Daniel P. Berrange + +=head1 COPYRIGHT + +Copyright (C) 2004-2011 Daniel P. Berrange + +=head1 SEE ALSO + +L, L, L, L, L, L + +=cut diff --git a/lib/Net/DBus/Binding/Message/Error.pm b/lib/Net/DBus/Binding/Message/Error.pm new file mode 100644 index 0000000..379e1e9 --- /dev/null +++ b/lib/Net/DBus/Binding/Message/Error.pm @@ -0,0 +1,124 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Binding::Message::Error - a message encoding a method call error + +=head1 SYNOPSIS + + use Net::DBus::Binding::Message::Error; + + my $error = Net::DBus::Binding::Message::Error->new( + replyto => $method_call, + name => "org.example.myobject.FooException", + description => "Unable to do Foo when updating bar"); + + $connection->send($error); + +=head1 DESCRIPTION + +This module is part of the low-level DBus binding APIs, and +should not be used by application code. No guarentees are made +about APIs under the C namespace being +stable across releases. + +This module provides a convenience constructor for creating +a message representing an error condition. + +=head1 METHODS + +=over 4 + +=cut + +package Net::DBus::Binding::Message::Error; + +use 5.006; +use strict; +use warnings; + +use Net::DBus; +use base qw(Net::DBus::Binding::Message); + +=item my $error = Net::DBus::Binding::Message::Error->new( + replyto => $method_call, name => $name, description => $description); + +Creates a new message, representing an error which occurred during +the handling of the method call object passed in as the C +parameter. The C parameter is the formal name of the error +condition, while the C is a short piece of text giving +more specific information on the error. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my %params = @_; + + my $replyto = exists $params{replyto} ? $params{replyto} : die "replyto parameter is required"; + + my $msg = exists $params{message} ? $params{message} : + Net::DBus::Binding::Message::Error::_create + ( + $replyto->{message}, + ($params{name} ? $params{name} : die "name parameter is required"), + ($params{description} ? $params{description} : die "description parameter is required")); + + my $self = $class->SUPER::new(message => $msg); + + bless $self, $class; + + return $self; +} + +=item my $name = $error->get_error_name + +Returns the formal name of the error, as previously passed in via +the C parameter in the constructor. + +=cut + +sub get_error_name { + my $self = shift; + + return $self->{message}->dbus_message_get_error_name; +} + +1; + +__END__ + +=back + +=head1 AUTHOR + +Daniel P. Berrange. + +=head1 COPYRIGHT + +Copyright (C) 2004-2009 Daniel P. Berrange + +=head1 SEE ALSO + +L + +=cut diff --git a/lib/Net/DBus/Binding/Message/MethodCall.pm b/lib/Net/DBus/Binding/Message/MethodCall.pm new file mode 100644 index 0000000..d5c0909 --- /dev/null +++ b/lib/Net/DBus/Binding/Message/MethodCall.pm @@ -0,0 +1,101 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Binding::Message::MethodCall - a message encoding a method call + +=head1 DESCRIPTION + +This module is part of the low-level DBus binding APIs, and +should not be used by application code. No guarentees are made +about APIs under the C namespace being +stable across releases. + +This module provides a convenience constructor for creating +a message representing a method call. + +=head1 METHODS + +=over 4 + +=cut + + +package Net::DBus::Binding::Message::MethodCall; + +use 5.006; +use strict; +use warnings; + +use Net::DBus; +use base qw(Exporter Net::DBus::Binding::Message); + +=item my $call = Net::DBus::Binding::Message::MethodCall->new( + service_name => $service, object_path => $object, + interface => $interface, method_name => $name); + +Create a message representing a call on the object located at +the path C within the client owning the well-known +name given by C. The method to be invoked has +the name C within the interface specified by the +C parameter. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my %params = @_; + + my $msg = exists $params{message} ? $params{message} : + Net::DBus::Binding::Message::MethodCall::_create + ( + ($params{service_name} ? $params{service_name} : die "service_name parameter is required"), + ($params{object_path} ? $params{object_path} : die "object_path parameter is required"), + ($params{interface} ? $params{interface} : die "interface parameter is required"), + ($params{method_name} ? $params{method_name} : die "method_name parameter is required")); + + my $self = $class->SUPER::new(message => $msg); + + bless $self, $class; + + return $self; +} + +1; + +__END__ + +=back + +=head1 AUTHOR + +Daniel P. Berrange. + +=head1 COPYRIGHT + +Copyright (C) 2004-2009 Daniel P. Berrange + +=head1 SEE ALSO + +L + +=cut diff --git a/lib/Net/DBus/Binding/Message/MethodReturn.pm b/lib/Net/DBus/Binding/Message/MethodReturn.pm new file mode 100644 index 0000000..c91f7b4 --- /dev/null +++ b/lib/Net/DBus/Binding/Message/MethodReturn.pm @@ -0,0 +1,93 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Binding::Message::MethodReturn - a message encoding a method return + +=head1 DESCRIPTION + +This module is part of the low-level DBus binding APIs, and +should not be used by application code. No guarentees are made +about APIs under the C namespace being +stable across releases. + +This module provides a convenience constructor for creating +a message representing an method return. + +=head1 METHODS + +=over 4 + +=cut + +package Net::DBus::Binding::Message::MethodReturn; + +use 5.006; +use strict; +use warnings; + +use Net::DBus; +use base qw(Exporter Net::DBus::Binding::Message); + +=item my $return = Net::DBus::Binding::Message::MethodReturn->new( + call => $method_call); + +Create a message representing a reply to the method call passed in +the C parameter. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my %params = @_; + + my $call = exists $params{call} ? $params{call} : die "call parameter is required"; + + my $msg = exists $params{message} ? $params{message} : + Net::DBus::Binding::Message::MethodReturn::_create($call->{message}); + + my $self = $class->SUPER::new(message => $msg); + + bless $self, $class; + + return $self; +} + +1; + +__END__ + +=back + +=head1 AUTHOR + +Daniel P. Berrange. + +=head1 COPYRIGHT + +Copyright (C) 2005-2009 Daniel P. Berrange + +=head1 SEE ALSO + +L + +=cut diff --git a/lib/Net/DBus/Binding/Message/Signal.pm b/lib/Net/DBus/Binding/Message/Signal.pm new file mode 100644 index 0000000..05a03c8 --- /dev/null +++ b/lib/Net/DBus/Binding/Message/Signal.pm @@ -0,0 +1,111 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Binding::Message::Signal - a message encoding a signal + +=head1 SYNOPSIS + + use Net::DBus::Binding::Message::Signal; + + my $signal = Net::DBus::Binding::Message::Signal->new( + object_path => "/org/example/myobject", + interface => "org.example.myobject", + signal_name => "foo_changed"); + + $connection->send($signal); + +=head1 DESCRIPTION + +This module is part of the low-level DBus binding APIs, and +should not be used by application code. No guarentees are made +about APIs under the C namespace being +stable across releases. + +This module provides a convenience constructor for creating +a message representing a signal. + +=head1 METHODS + +=over 4 + +=cut + +package Net::DBus::Binding::Message::Signal; + +use 5.006; +use strict; +use warnings; + +use Net::DBus; +use base qw(Net::DBus::Binding::Message); + + +=item my $signal = Net::DBus::Binding::Message::Signal->new( + object_path => $path, interface => $interface, signal_name => $name); + +Creates a new message, representing a signal [to be] emitted by +the object located under the path given by the C +parameter. The name of the signal is given by the C +parameter, and is scoped to the interface given by the +C parameter. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my %params = @_; + + my $msg = exists $params{message} ? $params{message} : + Net::DBus::Binding::Message::Signal::_create + ( + ($params{object_path} ? $params{object_path} : die "object_path parameter is required"), + ($params{interface} ? $params{interface} : die "interface parameter is required"), + ($params{signal_name} ? $params{signal_name} : die "signal_name parameter is required")); + + my $self = $class->SUPER::new(message => $msg); + + bless $self, $class; + + return $self; +} + + +1; + +__END__ + +=back + +=head1 AUTHOR + +Daniel P. Berrange. + +=head1 COPYRIGHT + +Copyright (C) 2004-2009 Daniel P. Berrange + +=head1 SEE ALSO + +L + +=cut diff --git a/lib/Net/DBus/Binding/PendingCall.pm b/lib/Net/DBus/Binding/PendingCall.pm new file mode 100644 index 0000000..84b28b0 --- /dev/null +++ b/lib/Net/DBus/Binding/PendingCall.pm @@ -0,0 +1,177 @@ +# -*- perl -*- +# +# Copyright (C) 2006-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Binding::PendingCall - A handler for pending method replies + +=head1 SYNOPSIS + + my $call = Net::DBus::Binding::PendingCall->new(method_call => $call, + pending_call => $reply); + + # Wait for completion + $call->block; + + # And get the reply message + my $msg = $call->get_reply; + +=head1 DESCRIPTION + +This object is used when it is necessary to make asynchronous method +calls. It provides the means to be notified when the reply is finally +received. + +=head1 METHODS + +=over 4 + +=cut + +package Net::DBus::Binding::PendingCall; + +use 5.006; +use strict; +use warnings; + +use Net::DBus; +use Net::DBus::Binding::Message::MethodReturn; +use Net::DBus::Binding::Message::Error; + +=item my $call = Net::DBus::Binding::PendingCall->new(method_call => $method_call, + pending_call => $pending_call); + +Creates a new pending call object, with the C parameter +being a reference to the C +object whose reply is being waiting for. The C parameter +is a reference to the raw C pending call object. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my %params = @_; + my $self = {}; + + $self->{connection} = exists $params{connection} ? $params{connection} : die "connection parameter is required"; + $self->{method_call} = exists $params{method_call} ? $params{method_call} : die "method_call parameter is required"; + $self->{pending_call} = exists $params{pending_call} ? $params{pending_call} : die "pending_call parameter is required"; + + bless $self, $class; + + return $self; +} + +=item $call->cancel + +Cancel the pending call, causing any reply that is later received +to be discarded. + +=cut + +sub cancel { + my $self = shift; + + $self->{pending_call}->dbus_pending_call_cancel(); +} + + +=item my $boolean = $call->get_completed + +Returns a true value if the pending call has received its reply, +or a timeout has occurred. + +=cut + +sub get_completed { + my $self = shift; + + $self->{pending_call}->dbus_pending_call_get_completed(); +} + +=item $call->block + +Block the caller until the reply is received or a timeout +occurrs. + +=cut + +sub block { + my $self = shift; + + $self->{pending_call}->dbus_pending_call_block(); +} + +=item my $msg = $call->get_reply; + +Retrieves the C object associated +with the complete call. + +=cut + +sub get_reply { + my $self = shift; + + my $reply = $self->{pending_call}->_steal_reply(); + my $type = $reply->dbus_message_get_type; + if ($type == &Net::DBus::Binding::Message::MESSAGE_TYPE_ERROR) { + return $self->{connection}->make_raw_message($reply); + } elsif ($type == &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN) { + return $self->{connection}->make_raw_message($reply); + } else { + die "unknown method reply type $type"; + } +} + +=item $call->set_notify($coderef); + +Sets a notification function to be invoked when the pending +call completes. The callback will be passed a single argument +which is this pending call object. + +=cut + +sub set_notify { + my $self = shift; + my $cb = shift; + + $self->{pending_call}->_set_notify($cb); +} + +1; + +=pod + +=back + +=head1 AUTHOR + +Daniel P. Berrange + +=head1 COPYRIGHT + +Copyright (C) 2006-2011 Daniel P. Berrange + +=head1 SEE ALSO + +L, L, L + +=cut diff --git a/lib/Net/DBus/Binding/Server.pm b/lib/Net/DBus/Binding/Server.pm new file mode 100644 index 0000000..224ba81 --- /dev/null +++ b/lib/Net/DBus/Binding/Server.pm @@ -0,0 +1,232 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Binding::Server - A server to accept incoming connections + +=head1 SYNOPSIS + +Creating a new server and accepting client connections + + use Net::DBus::Binding::Server; + + my $server = Net::DBus::Binding::Server->new(address => "unix:path=/path/to/socket"); + + $server->connection_callback(\&new_connection); + + sub new_connection { + my $connection = shift; + + .. work with new connection... + } + +Managing the server and new connections in an event loop + + my $reactor = Net::DBus::Binding::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. +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 + +package Net::DBus::Binding::Server; + +use 5.006; +use strict; +use warnings; + +use Net::DBus; +use Net::DBus::Binding::Connection; + +=item my $server = Net::DBus::Binding::Server->new(address => "unix:path=/path/to/socket"); + +Creates a new server binding it to the socket specified by the +C
parameter. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my %params = @_; + my $self = {}; + + $self->{address} = exists $params{address} ? $params{address} : die "address parameter is required"; + $self->{server} = Net::DBus::Binding::Server::_open($self->{address}); + + bless $self, $class; + + $self->{server}->_set_owner($self); + + $self->{_callback} = sub { + my $server = shift; + my $rawcon = shift; + my $con = Net::DBus::Binding::Connection->new(connection => $rawcon); + + if ($server->{connection_callback}) { + &{$server->{connection_callback}}($server, $con); + } + }; + + return $self; +} + +=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; + + return $self->{server}->dbus_server_get_is_connected(); +} + +=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; + + return $self->{server}->dbus_server_disconnect(); +} + + +=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 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; + my $remove = shift; + my $toggled = shift; + + $self->{add_watch} = $add; + $self->{remove_watch} = $remove; + $self->{toggled_watch} = $toggled; + + $self->{server}->_set_watch_callbacks(); +} + +=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 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(); +} + +=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 object representing +the client. + +=cut + +sub set_connection_callback { + my $self = shift; + my $callback = shift; + + $self->{connection_callback} = $callback; + + $self->{server}->_set_connection_callback(); +} + + +1; + + +=pod + +=back + +=head1 AUTHOR + +Daniel P. Berrange + +=head1 COPYRIGHT + +Copyright (C) 2004-2011 Daniel P. Berrange + +=head1 SEE ALSO + +L, L, L, L, L, L + +=cut diff --git a/lib/Net/DBus/Binding/Value.pm b/lib/Net/DBus/Binding/Value.pm new file mode 100644 index 0000000..0973b00 --- /dev/null +++ b/lib/Net/DBus/Binding/Value.pm @@ -0,0 +1,115 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Binding::Value - Strongly typed data value + +=head1 SYNOPSIS + + # Import the convenience functions + use Net::DBus qw(:typing); + + # Call a method with passing an int32 + $object->doit(dint32("3")); + +=head1 DESCRIPTION + +This module provides a simple wrapper around a raw Perl value, +associating an explicit DBus type with the value. This is used +in cases where a client is communicating with a server which does +not provide introspection data, but for which the basic data types +are not sufficient. This class should not be used directly, rather +the convenience functions in L be called. + +=head1 METHODS + +=over 4 + +=cut + +package Net::DBus::Binding::Value; + +use strict; +use warnings; + +=item my $value = Net::DBus::Binding::Value->new($type, $value); + +Creates a wrapper for the perl value C<$value> marking it as having +the dbus data type C<$type>. It is not neccessary to call this method +directly, instead the data typing methods in the L object +should be used. + +=cut + +sub new { + my $class = shift; + my $self = []; + + $self->[0] = shift; + $self->[1] = shift; + + bless $self, $class; + + return $self; +} + +=item my $raw = $value->value + +Returns the raw perl value wrapped by this object + +=cut + +sub value { + my $self = shift; + return $self->[1]; +} + +=item my $type = $value->type + +Returns the dbus data type this value is marked +as having + +=cut + +sub type { + my $self = shift; + return $self->[0]; +} + +1; + +=pod + +=back + +=head1 AUTHOR + +Daniel P. Berrange + +=head1 COPYRIGHT + +Copyright (C) 2004-2011 Daniel P. Berrange + +=head1 SEE ALSO + +L, L, L + +=cut diff --git a/lib/Net/DBus/Binding/Watch.pm b/lib/Net/DBus/Binding/Watch.pm new file mode 100644 index 0000000..8294cf7 --- /dev/null +++ b/lib/Net/DBus/Binding/Watch.pm @@ -0,0 +1,73 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Binding::Watch - binding to the dbus watch API + +=cut + +package Net::DBus::Binding::Watch; + +use 5.006; +use strict; +use warnings; + +use Net::DBus; + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. + + my $constname; + our $AUTOLOAD; + ($constname = $AUTOLOAD) =~ s/.*:://; + + die "&Net::DBus::Binding::Watch::constant not defined" if $constname eq '_constant'; + + if (!exists $Net::DBus::Binding::Watch::_constants{$constname}) { + die "no such constant \$Net::DBus::Binding::Watch::$constname"; + } + + { + no strict 'refs'; + *$AUTOLOAD = sub { $Net::DBus::Binding::Watch::_constants{$constname} }; + } + goto &$AUTOLOAD; +} + +1; + +=pod + +=head1 AUTHOR + +Daniel P. Berrange. + +=head1 COPYRIGHT + +Copyright (C) 2004-2011 Daniel P. Berrange + +=head1 SEE ALSO + +L + +=cut + diff --git a/lib/Net/DBus/Callback.pm b/lib/Net/DBus/Callback.pm new file mode 100644 index 0000000..c118a14 --- /dev/null +++ b/lib/Net/DBus/Callback.pm @@ -0,0 +1,142 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Callback - a callback for receiving reactor events + +=head1 SYNOPSIS + + use Net::DBus::Callback; + + # Assume we have a 'terminal' object and its got a method + # to be invoked everytime there is input on its terminal. + # + # To create a callback to invoke this method one might use + my $cb = Net::DBus::Callback->new(object => $terminal, + method => "handle_stdio"); + + + # Whatever is monitoring the stdio channel, would then + # invoke the callback, perhaps passing in a parameter with + # some 'interesting' data, such as number of bytes available + $cb->invoke($nbytes) + + #... which results in a call to + # $terminal->handle_stdio($nbytes) + +=head1 DESCRIPTION + +This module provides a simple container for storing details +about a callback to be invoked at a later date. It is used +when registering to receive events from the L +class. NB use of this module in application code is no longer +neccessary and it remains purely for backwards compatability. +Instead you can simply pass a subroutine code reference in +any place where a callback is desired. + +=head1 METHODS + +=over 4 + +=cut + +package Net::DBus::Callback; + +use 5.006; +use strict; +use warnings; + +=item my $cb = Net::DBus::Callback->new(method => $name, [args => \@args]) + +Creates a new callback object, for invoking a plain old function. The C +parameter should be the fully qualified function name to invoke, including the +package name. The optional C parameter is an array reference of parameters +to be pass to the callback, in addition to those passed into the C method. + +=item my $cb = Net::DBus::Callback->new(object => $object, method => $name, [args => \@args]) + +Creates a new callback object, for invoking a method on an object. The C +parameter should be the name of the method to invoke, while the C parameter +should be a blessed object on which the method will be invoked. The optional C +parameter is an array reference of parameters to be pass to the callback, in addition +to those passed into the C method. + +=cut + +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} : die "method parameter is required"; + $self->{args} = $params{args} ? $params{args} : []; + + bless $self, $class; + + return $self; +} + +=item $cb->invoke(@args) + +Invokes the callback. The argument list passed to the callback +is a combination of the arguments supplied in the callback +constructor, followed by the arguments supplied in the C +method. + +=cut + +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; + +__END__ + +=back + +=head1 AUTHOR + +Daniel P. Berrange. + +=head1 COPYRIGHT + +Copyright (C) 2004-2011 Daniel P. Berrange + +=head1 SEE ALSO + +L + +=cut + diff --git a/lib/Net/DBus/Dumper.pm b/lib/Net/DBus/Dumper.pm new file mode 100644 index 0000000..1db2e3b --- /dev/null +++ b/lib/Net/DBus/Dumper.pm @@ -0,0 +1,256 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Dumper - Stringify Net::DBus objects suitable for printing + +=head1 SYNOPSIS + + use Net::DBus::Dumper; + + use Net::DBus; + + # Dump out info about the bus + my $bus = Net::DBus->find; + print dbus_dump($bus); + + # Dump out info about a service + my $service = $bus->get_service("org.freedesktop.DBus"); + print dbus_dump($service); + + # Dump out info about an object + my $object = $service->get_object("/org/freedesktop/DBus"); + print dbus_dump($object); + +=head1 DESCRIPTION + +This module serves as a debugging aid, providing a means to stringify +a DBus related object in a form suitable for printing out. It can +stringify any of the Net::DBus:* objects, generating the following +information for each + +=over 4 + +=item Net::DBus + +A list of services registered with the bus + +=item Net::DBus::Service +=item Net::DBus::RemoteService + +The service name + +=item Net::DBus::Object +=item Net::DBus::RemoteObject + +The list of all exported methods, and signals, along with their +parameter and return types. + +=back + +=head1 METHODS + +=over 4 + +=cut + +package Net::DBus::Dumper; + +use strict; +use warnings; + +use base qw(Exporter); + +use vars qw(@EXPORT); + +@EXPORT = qw(dbus_dump); + + +=item my @data = dbus_dump($object); + +Generates a stringified representation of an object. The object +passed in as the parameter must be an instance of one of L, +L, L, +L, L. The stringified +representation will be returned as a list of strings, with newlines +in appropriate places, such that it can be passed string to the C +method. + +=cut + +sub dbus_dump { + my $object = shift; + + my $ref = ref($object); + die "object '$object' is not a reference" unless defined $ref; + + if ($object->isa("Net::DBus::Object") || + $object->isa("Net::DBus::RemoteObject")) { + return &_dbus_dump_introspector($object->_introspector); + } elsif ($object->isa("Net::DBus::RemoteService") || + $object->isa("Net::DBus::Service")) { + return &_dbus_dump_service($object); + } elsif ($object->isa("Net::DBus")) { + return &_dbus_dump_bus($object); + } +} + + +sub _dbus_dump_introspector { + my $ins = shift; + + my @data; + push @data, "Object: ", $ins->get_object_path, "\n"; + foreach my $interface (sort { $a cmp $b } $ins->list_interfaces) { + push @data, " Interface: ", $interface, "\n"; + foreach my $method (sort {$a cmp $b } $ins->list_methods($interface)) { + push @data, " Method: ", $method, "\n"; + my @paramnames = $ins->get_method_param_names($interface, $method); + foreach my $param ($ins->get_method_params($interface, $method)) { + my $name = @paramnames ? shift @paramnames : undef; + push @data, &_dbus_dump_types(" > ", $param, $name); + } + my @returnnames = $ins->get_method_return_names($interface, $method); + foreach my $param ($ins->get_method_returns($interface, $method)) { + my $name = @returnnames ? shift @returnnames : undef; + push @data, &_dbus_dump_types(" < ", $param, $name); + } + } + foreach my $signal (sort { $a cmp $b } $ins->list_signals($interface)) { + push @data, " Signal: ", $signal, "\n"; + my @paramnames = $ins->get_signal_param_names($interface, $signal); + foreach my $param ($ins->get_signal_params($interface, $signal)) { + my $name = @paramnames ? shift @paramnames : undef; + push @data, &_dbus_dump_types(" > ", $param, $name); + } + } + foreach my $child (sort { $a cmp $b } $ins->list_children()) { + push @data, " Child: ", $child, "\n"; + } + } + return @data; +} + +sub _dbus_dump_types { + my $indent = shift; + my $type = shift; + my $name = shift; + + my @data; + push @data, $indent; + if (ref($type)) { + push @data, $type->[0]; + if (defined $name) { + push @data, " ($name)"; + } + push @data, "\n"; + for (my $i = 1 ; $i <= $#{$type} ; $i++) { + push @data, &_dbus_dump_types($indent . " ", $type->[$i]); + } + } else { + push @data, $type; + if (defined $name) { + push @data, " ($name)"; + } + push @data, "\n"; + } + return @data; +} + + +sub _dbus_dump_service { + my $service = shift; + + my @data; + push @data, "Service: ", $service->get_service_name, "\n"; + + my @objects = &_dbus_dump_children($service, "/"); + foreach (@objects) { + push @data, " Object: $_\n"; + } + return @data; +} + +sub _dbus_dump_children { + my $service = shift; + my $path = shift; + + my $exp = $service->get_object($path); + my @exports = eval { + my $ins = $exp->_introspector; + if ($ins) { + return $ins->list_children; + } + return (); + }; + my @objects = map { $path eq "/" ? $path . $_ : $path . "/" . $_ } @exports; + if ($@) { + #push @objects, " Could not lookup objects under path '$path'\n"; + } + foreach my $child (@exports) { + push @objects, _dbus_dump_children ($service, $path eq "/" ? $path . $child : $path . "/" . $child); + } + return @objects; +} + +sub _dbus_dump_bus { + my $bus = shift; + + my @data; + push @data, "Bus: \n"; + + + my $dbus = $bus->get_service("org.freedesktop.DBus"); + my $obj = $dbus->get_object("/org/freedesktop/DBus"); + my $names = $obj->ListNames(); + + foreach (sort { $a cmp $b } @{$names}) { + push @data, " Service: ", $_, "\n"; + } + return @data; +} + +1; + +=pod + +=back + +=head1 BUGS + +It should print out a list of object paths registered against a +service, but this only currently works for service implemented +in Perl + +=head1 AUTHOR + +Daniel P. Berrange + +=head1 COPYRIGHT + +Copyright (C) 2005-2011 Daniel P. Berrange + +=head1 SEE ALSO + +L, L, L, +L, L, L. + +=cut diff --git a/lib/Net/DBus/Error.pm b/lib/Net/DBus/Error.pm new file mode 100644 index 0000000..9ad9804 --- /dev/null +++ b/lib/Net/DBus/Error.pm @@ -0,0 +1,170 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Error - Error details for remote method invocation + +=head1 SYNOPSIS + + package Music::Player::UnknownFormat; + + use base qw(Net::DBus::Error); + + # Define an error type for unknown track encoding type + # for a music player service + sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->SUPER::new(name => "org.example.music.UnknownFormat", + message => "Unknown track encoding format"); + } + + + package Music::Player::Engine; + + ...snip... + + # Play either mp3 or ogg music tracks, otherwise + # thrown an error + sub play { + my $self = shift; + my $url = shift; + + if ($url =~ /\.(mp3|ogg)$/) { + ...play the track + } else { + die Music::Player::UnknownFormat->new(); + } + } + + +=head1 DESCRIPTION + +This objects provides for strongly typed error handling. Normally +a service would simply call + + die "some message text" + +When returning the error condition to the calling DBus client, the +message is associated with a generic error code or "org.freedesktop.DBus.Failed". +While this suffices for many applications, occasionally it is desirable +to be able to catch and handle specific error conditions. For such +scenarios the service should create subclasses of the C +object providing in a custom error name. This error name is then sent back +to the client instead of the genreic "org.freedesktop.DBus.Failed" code. + +=head1 METHODS + +=over 4 + +=cut + +package Net::DBus::Error; + +use strict; +use warnings; + + +use overload ('""' => 'stringify'); + +=item my $error = Net::DBus::Error->new(name => $error_name, + message => $description); + +Creates a new error object whose name is given by the C +parameter, and long descriptive text is provided by the +C parameter. The C parameter has certain +formatting rules which must be adhered to. It must only contain +the letters 'a'-'Z', '0'-'9', '-', '_' and '.'. There must be +at least two components separated by a '.', For example a valid +name is 'org.example.Music.UnknownFormat'. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = {}; + my %params = @_; + + $self->{name} = $params{name} ? $params{name} : die "name parameter is required"; + $self->{message} = $params{message} ? $params{message} : die "message parameter is required"; + + bless $self, $class; + + return $self; +} + +=item $error->name + +Returns the DBus error name associated with the object. + +=cut + +sub name { + my $self = shift; + return $self->{name}; +} + +=item $error->message + +Returns the descriptive text/message associated with the +error condition. + +=cut + +sub message { + my $self = shift; + return $self->{message}; +} + +=item $error->stringify + +Formats the error as a string in a manner suitable for +printing out / logging / displaying to the user, etc. + +=cut + +sub stringify { + my $self = shift; + + return $self->{name} . ": " . $self->{message} . ($self->{message} =~ /\n$/ ? "" : "\n"); +} + + +1; + +=pod + +=back + +=head1 AUTHOR + +Daniel P. Berrange + +=head1 COPYRIGHT + +Copyright (C) 2005-2011 Daniel P. Berrange + +=head1 SEE ALSO + +L, L + +=cut diff --git a/lib/Net/DBus/Exporter.pm b/lib/Net/DBus/Exporter.pm new file mode 100644 index 0000000..dde44b9 --- /dev/null +++ b/lib/Net/DBus/Exporter.pm @@ -0,0 +1,618 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Exporter - Export object methods and signals to the bus + +=head1 SYNOPSIS + + # Define a new package for the object we're going + # to export + package Demo::HelloWorld; + + # Specify the main interface provided by our object + use Net::DBus::Exporter qw(org.example.demo.Greeter); + + # We're going to be a DBus object + use base qw(Net::DBus::Object); + + # Ensure only explicitly exported methods can be invoked + dbus_strict_exports; + + # Export a 'Greeting' signal taking a stringl string parameter + dbus_signal("Greeting", ["string"]); + + # Export 'Hello' as a method accepting a single string + # parameter, and returning a single string value + dbus_method("Hello", ["string"], ["string"]); + + # Export 'Goodbye' as a method accepting a single string + # parameter, and returning a single string, but put it + # in the 'org.exaple.demo.Farewell' interface + dbus_method("Goodbye", ["string"], ["string"], "org.example.demo.Farewell"); + +=head1 DESCRIPTION + +The C module is used to export methods +and signals defined in an object to the message bus. Since +Perl is a loosely typed language it is not possible to automatically +determine correct type information for methods to be exported. +Thus when sub-classing L, this package will +provide the type information for methods and signals. + +When importing this package, an optional argument can be supplied +to specify the default interface name to associate with methods +and signals, for which an explicit interface is not specified. +Thus in the common case of objects only providing a single interface, +this removes the need to repeat the interface name against each +method exported. + +=head1 SCALAR TYPES + +When specifying scalar data types for parameters and return values, +the following string constants must be used to denote the data +type. When values corresponding to these types are (un)marshalled +they are represented as the Perl SCALAR data type (see L). + +=over 4 + +=item "string" + +A UTF-8 string of characters + +=item "int16" + +A 16-bit signed integer + +=item "uint16" + +A 16-bit unsigned integer + +=item "int32" + +A 32-bit signed integer + +=item "uint32" + +A 32-bit unsigned integer + +=item "int64" + +A 64-bit signed integer. NB, this type is not supported by +many builds of Perl on 32-bit platforms, so if used, your +data is liable to be truncated at 32-bits. + +=item "uint64" + +A 64-bit unsigned integer. NB, this type is not supported by +many builds of Perl on 32-bit platforms, so if used, your +data is liable to be truncated at 32-bits. + +=item "byte" + +A single 8-bit byte + +=item "bool" + +A boolean value + +=item "double" + +An IEEE double-precision floating point + +=back + +=head1 COMPOUND TYPES + +When specifying compound data types for parameters and return +values, an array reference must be used, with the first element +being the name of the compound type. + +=over 4 + +=item ["array", ARRAY-TYPE] + +An array of values, whose type os C. The C +can be either a scalar type name, or a nested compound type. When +values corresponding to the array type are (un)marshalled, they +are represented as the Perl ARRAY data type (see L). If, +for example, a method was declared to have a single parameter with +the type, ["array", "string"], then when calling the method one +would provide a array reference of strings: + + $object->hello(["John", "Doe"]) + +=item ["dict", KEY-TYPE, VALUE-TYPE] + +A dictionary of values, more commonly known as a hash table. The +C is the name of the scalar data type used for the dictionary +keys. The C is the name of the scalar, or compound +data type used for the dictionary values. When values corresponding +to the dict type are (un)marshalled, they are represented as the +Perl HASH data type (see L). If, for example, a method was +declared to have a single parameter with the type ["dict", "string", "string"], +then when calling the method one would provide a hash reference +of strings, + + $object->hello({forename => "John", surname => "Doe"}); + +=item ["struct", VALUE-TYPE-1, VALUE-TYPE-2] + +A structure of values, best thought of as a variation on the array +type where the elements can vary. Many languages have an explicit +name associated with each value, but since Perl does not have a +native representation of structures, they are represented by the +LIST data type. If, for exaple, a method was declared to have a single +parameter with the type ["struct", "string", "string"], corresponding +to the C structure + + struct { + char *forename; + char *surname; + } name; + +then, when calling the method one would provide an array refernce +with the values orded to match the structure + + $object->hello(["John", "Doe"]); + +=back + +=head1 MAGIC TYPES + +When specifying introspection data for an exported service, there +are a couple of so called C types. Parameters declared as +magic types are not visible to clients, but instead their values +are provided automatically by the server side bindings. One use of +magic types is to get an extra parameter passed with the unique +name of the caller invoking the method. + +=over 4 + +=item "caller" + +The value passed in is the unique name of the caller of the method. +Unique names are strings automatically assigned to client connections +by the bus daemon, for example ':1.15' + +=item "serial" + +The value passed in is an integer within the scope of a caller, which +increments on every method call. + +=back + +=head1 ANNOTATIONS + +When exporting methods, signals & properties, in addition to the core +data typing information, a number of metadata annotations are possible. +These are specified by passing a hash reference with the desired keys +as the last parameter when defining the export. The following annotations +are currently supported + +=over 4 + +=item no_return + +Indicate that this method does not return any value, and thus no reply +message should be sent over the wire, likewise informing the clients +not to expect / wait for a reply message + +=item deprecated + +Indicate that use of this method/signal/property is discouraged, and +it may disappear altogether in a future release. Clients will typically +print out a warning message when a deprecated method/signal/property +is used. + +=item param_names + +An array of strings specifying names for the input parameters of the +method or signal. If omitted, no names will be assigned. + +=item return_names + +An array of strings specifying names for the return parameters of the +method. If omitted, no names will be assigned. + +=back + +=head1 METHODS + +=over 4 + +=cut + +package Net::DBus::Exporter; + +use vars qw(@ISA @EXPORT %dbus_exports %dbus_introspectors); + +use Net::DBus::Binding::Introspector; + +use warnings; +use strict; + +use Exporter; +@ISA = qw(Exporter); + +@EXPORT = qw(dbus_method dbus_signal dbus_property dbus_no_strict_exports); + + +sub import { + my $class = shift; + + my $caller = caller; + if (exists $dbus_exports{$caller}) { + warn "$caller is already registered with Net::DBus::Exporter"; + return; + } + + $dbus_exports{$caller} = { + strict => 1, + methods => {}, + signals => {}, + props => {}, + }; + die "usage: use Net::DBus::Exporter 'interface-name';" unless @_; + + my $interface = shift; + &_validate_interface($interface); + $dbus_exports{$caller}->{interface} = $interface; + + $class->export_to_level(1, "", @EXPORT); +} + +sub _dbus_introspector { + my $class = shift; + + if (!exists $dbus_exports{$class}) { + # If this class has not been exported, lets look + # at the parent class & return its introspection + # data instead. + no strict 'refs'; + if (defined (*{"${class}::ISA"})) { + my @isa = @{"${class}::ISA"}; + foreach my $parent (@isa) { + # We don't recurse to Net::DBus::Object + # since we need to give sub-classes the + # choice of not supporting introspection + next if $parent eq "Net::DBus::Object"; + + my $ins = &_dbus_introspector($parent); + if ($ins) { + return $ins; + } + } + } + return undef; + } + + unless (exists $dbus_introspectors{$class}) { + my $is = Net::DBus::Binding::Introspector->new(strict=>$dbus_exports{$class}->{strict}); + &_dbus_introspector_add($class, $is); + $dbus_introspectors{$class} = $is; + } + + return $dbus_introspectors{$class}; +} + +sub _dbus_introspector_add { + my $class = shift; + my $introspector = shift; + + my $exports = $dbus_exports{$class}; + if ($exports) { + foreach my $method (keys %{$exports->{methods}}) { + my ($params, $returns, $interface, $attributes, $paramnames, $returnnames) = @{$exports->{methods}->{$method}}; + $introspector->add_method($method, $params, $returns, $interface, $attributes, $paramnames, $returnnames); + } + foreach my $prop (keys %{$exports->{props}}) { + my ($type, $access, $interface, $attributes) = @{$exports->{props}->{$prop}}; + $introspector->add_property($prop, $type, $access, $interface, $attributes); + } + foreach my $signal (keys %{$exports->{signals}}) { + my ($params, $interface, $attributes, $paramnames) = @{$exports->{signals}->{$signal}}; + $introspector->add_signal($signal, $params, $interface, $attributes, $paramnames); + } + } + + if (defined (*{"${class}::ISA"})) { + no strict "refs"; + my @isa = @{"${class}::ISA"}; + foreach my $parent (@isa) { + &_dbus_introspector_add($parent, $introspector); + } + } +} + +=item dbus_method($name, $params, $returns, [\%annotations]); + +=item dbus_method($name, $params, $returns, $interface, [\%annotations]); + +Exports a method called C<$name>, having parameters whose types +are defined by C<$params>, and returning values whose types are +defined by C<$returns>. If the C<$interface> parameter is +provided, then the method is associated with that interface, otherwise +the default interface for the calling package is used. The +value for the C<$params> parameter should be an array reference +with each element defining the data type of a parameter to the +method. Likewise, the C<$returns> parameter should be an array +reference with each element defining the data type of a return +value. If it not possible to export a method which accepts a +variable number of parameters, or returns a variable number of +values. + +=cut + +sub dbus_method { + my $name = shift; + my $params = []; + my $returns = []; + my $caller = caller; + my $interface = $dbus_exports{$caller}->{interface}; + my %attributes; + + if (@_ && ref($_[0]) eq "ARRAY") { + $params = shift; + } + if (@_ && ref($_[0]) eq "ARRAY") { + $returns = shift; + } + if (@_ && !ref($_[0])) { + $interface = shift; + &_validate_interface($interface); + } + if (@_ && ref($_[0]) eq "HASH") { + %attributes = %{$_[0]}; + } + + if (!$interface) { + die "interface not specified & no default interface defined"; + } + + my $param_names = []; + if ( $attributes{param_names} ) { + $param_names = $attributes{param_names} if ref($attributes{param_names}) eq "ARRAY"; + delete($attributes{param_names}); + } + my $return_names = []; + if ( $attributes{return_names} ) { + $return_names = $attributes{return_names} if ref($attributes{return_names}) eq "ARRAY"; + delete($attributes{return_names}); + } + + $dbus_exports{$caller}->{methods}->{$name} = [$params, $returns, $interface, \%attributes, $param_names, $return_names]; +} + +=item dbus_no_strict_exports(); + +If a object is using the Exporter to generate DBus introspection data, +the default behaviour is to only allow invocation of methods which have +been explicitly exported. + +To allow clients to access methods which have not been explicitly +exported, call C. NB, doing this may be +a security risk if you have methods considered to be "private" for +internal use only. As such this method should not normally be used. +It is here only to allow switching export behaviour to match earlier +releases. + +=cut + +sub dbus_no_strict_exports { + my $caller = caller; + $dbus_exports{$caller}->{strict} = 0; +} + +=item dbus_property($name, $type, $access, [\%attributes]); + +=item dbus_property($name, $type, $access, $interface, [\%attributes]); + +Exports a property called C<$name>, whose data type is C<$type>. +If the C<$interface> parameter is provided, then the property is +associated with that interface, otherwise the default interface +for the calling package is used. + +=cut + +sub dbus_property { + my $name = shift; + my $type = "string"; + my $access = "readwrite"; + my $caller = caller; + my $interface = $dbus_exports{$caller}->{interface}; + my %attributes; + + if (@_ && (!ref($_[0]) || (ref($_[0]) eq "ARRAY"))) { + $type = shift; + } + if (@_ && !ref($_[0])) { + $access = shift; + } + if (@_ && !ref($_[0])) { + $interface = shift; + &_validate_interface($interface); + } + if ($_ && ref($_[0]) eq "HASH") { + %attributes = %{$_[0]}; + } + + if (!$interface) { + die "interface not specified & no default interface defined"; + } + + $dbus_exports{$caller}->{props}->{$name} = [$type, $access, $interface, \%attributes]; +} + + +=item dbus_signal($name, $params, [\%attributes]); + +=item dbus_signal($name, $params, $interface, [\%attributes]); + +Exports a signal called C<$name>, having parameters whose types +are defined by C<$params>. If the C<$interface> parameter is +provided, then the signal is associated with that interface, otherwise +the default interface for the calling package is used. The +value for the C<$params> parameter should be an array reference +with each element defining the data type of a parameter to the +signal. Signals do not have return values. It not possible to +export a signal which has a variable number of parameters. + +=cut + +sub dbus_signal { + my $name = shift; + my $params = []; + my $caller = caller; + my $interface = $dbus_exports{$caller}->{interface}; + my %attributes; + + if (@_ && ref($_[0]) eq "ARRAY") { + $params = shift; + } + if (@_ && !ref($_[0])) { + $interface = shift; + &_validate_interface($interface); + } + if (@_ && ref($_[0]) eq "HASH") { + %attributes = %{$_[0]}; + } + + if (!$interface) { + die "interface not specified & no default interface defined"; + } + + my $param_names = []; + if ( $attributes{param_names} ) { + $param_names = $attributes{param_names} if ref($attributes{param_names}) eq "ARRAY"; + delete($attributes{param_names}); + } + + $dbus_exports{$caller}->{signals}->{$name} = [$params, $interface, \%attributes, $param_names]; +} + + +sub _validate_interface { + my $interface = shift; + + die "interface name '$interface' is not valid.\n" . + " * Interface names are composed of 1 or more elements separated by a\n" . + " period ('.') character. All elements must contain at least one character.\n" . + " * Each element must only contain the ASCII characters '[A-Z][a-z][0-9]_'\n" . + " and must not begin with a digit.\n" . + " * Interface names must contain at least one '.' (period) character (and\n" . + " thus at least two elements).\n" . + " * Interface names must not begin with a '.' (period) character.\n" + unless $interface =~ /^[a-zA-Z_]\w*(\.[a-zA-Z_]\w*)+$/; +} + +1; + +=back + +=head1 EXAMPLES + +=over 4 + +=item No paramters, no return values + +A method which simply prints "Hello World" each time its called + + sub Hello { + my $self = shift; + print "Hello World\n"; + } + + dbus_method("Hello", [], []); + +=item One string parameter, returning an boolean value + +A method which accepts a process name, issues the killall +command on it, and returns a boolean value to indicate whether +it was successful. + + sub KillAll { + my $self = shift; + my $processname = shift; + my $ret = system("killall $processname"); + return $ret == 0 ? 1 : 0; + } + + dbus_method("KillAll", ["string"], ["bool"]); + +=item One list of strings parameter, returning a dictionary + +A method which accepts a list of files names, stats them, and +returns a dictionary containing the last modification times. + + sub LastModified { + my $self = shift; + my $files = shift; + + my %mods; + foreach my $file (@{$files}) { + $mods{$file} = (stat $file)[9]; + } + return \%mods; + } + + dbus_method("LastModified", ["array", "string"], ["dict", "string", "int32"]); + +=item Annotating methods with metdata + +A method which is targetted for removal, and also does not +return any value + + sub PlayMP3 { + my $self = shift; + my $track = shift; + + system "mpg123 $track &"; + } + + dbus_method("PlayMP3", ["string"], [], { deprecated => 1, no_return => 1 }); + +Or giving names to input parameters: + + sub PlayMP3 { + my $self = shift; + my $track = shift; + + system "mpg123 $track &"; + } + + dbus_method("PlayMP3", ["string"], [], { param_names => ["track"] }); + +=back + +=head1 AUTHOR + +Daniel P. Berrange + +=head1 COPYRIGHT + +Copright (C) 2004-2011, Daniel Berrange. + +=head1 SEE ALSO + +L, L + +=cut diff --git a/lib/Net/DBus/Object.pm b/lib/Net/DBus/Object.pm new file mode 100644 index 0000000..41a9d1b --- /dev/null +++ b/lib/Net/DBus/Object.pm @@ -0,0 +1,721 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Object - Provide objects to the bus for clients to use + +=head1 SYNOPSIS + + # Connecting an object to the bus, under a service + package main; + + use Net::DBus; + + # Attach to the bus + my $bus = Net::DBus->find; + + # Acquire a service 'org.demo.Hello' + my $service = $bus->export_service("org.demo.Hello"); + + # Export our object within the service + my $object = Demo::HelloWorld->new($service); + + ....rest of program... + + # Define a new package for the object we're going + # to export + package Demo::HelloWorld; + + # Specify the main interface provided by our object + use Net::DBus::Exporter qw(org.example.demo.Greeter); + + # We're going to be a DBus object + use base qw(Net::DBus::Object); + + # Export a 'Greeting' signal taking a stringl string parameter + dbus_signal("Greeting", ["string"]); + + # Export 'Hello' as a method accepting a single string + # parameter, and returning a single string value + dbus_method("Hello", ["string"], ["string"]); + + sub new { + my $class = shift; + my $service = shift; + my $self = $class->SUPER::new($service, "/org/demo/HelloWorld"); + + bless $self, $class; + + return $self; + } + + sub Hello { + my $self = shift; + my $name = shift; + + $self->emit_signal("Greeting", "Hello $name"); + return "Said hello to $name"; + } + + # Export 'Goodbye' as a method accepting a single string + # parameter, and returning a single string, but put it + # in the 'org.exaple.demo.Farewell' interface + + dbus_method("Goodbye", ["string"], ["string"], "org.example.demo.Farewell"); + + sub Goodbye { + my $self = shift; + my $name = shift; + + $self->emit_signal("Greeting", "Goodbye $name"); + return "Said goodbye to $name"; + } + +=head1 DESCRIPTION + +This the base of all objects which are exported to the +message bus. It provides the core support for type introspection +required for objects exported to the message. When sub-classing +this object, methods can be created & tested as per normal Perl +modules. Then just as the L module is used to export +methods within a script, the L module is +used to export methods (and signals) to the message bus. + +All packages inheriting from this, will automatically have the +interface C registered +with L, and the C method within +this exported. + +=head1 METHODS + +=over 4 + +=cut + +package Net::DBus::Object; + +use 5.006; +use strict; +use warnings; + +our $ENABLE_INTROSPECT; + +BEGIN { + if ($ENV{DBUS_DISABLE_INTROSPECT}) { + $ENABLE_INTROSPECT = 0; + } else { + $ENABLE_INTROSPECT = 1; + } +} + +use Net::DBus::Exporter "org.freedesktop.DBus.Introspectable"; + +dbus_method("Introspect", [], ["string"]); + +dbus_method("Get", ["string", "string"], [["variant"]], "org.freedesktop.DBus.Properties"); +dbus_method("GetAll", ["string"], [["dict", "string", ["variant"]]], "org.freedesktop.DBus.Properties"); +dbus_method("Set", ["string", "string", ["variant"]], [], "org.freedesktop.DBus.Properties"); + +=item my $object = Net::DBus::Object->new($service, $path) + +This creates a new DBus object with an path of C<$path> +registered within the service C<$service>. The C<$path> +parameter should be a string complying with the usual +DBus requirements for object paths, while the C<$service> +parameter should be an instance of L. +The latter is typically obtained by calling the C +method on the L object. + +=item my $object = Net::DBus::Object->new($parentobj, $subpath) + +This creates a new DBus child object with an path of C<$subpath> +relative to its parent C<$parentobj>. The C<$subpath> +parameter should be a string complying with the usual +DBus requirements for object paths, while the C<$parentobj> +parameter should be an instance of L. + +=cut + +sub new { + my $class = shift; + my $self = {}; + + my $parent = shift; + my $path = shift; + + $self->{parent} = $parent; + if ($parent->isa(__PACKAGE__)) { + $self->{service} = $parent->get_service; + $self->{object_path} = $parent->get_object_path . $path; + } else { + $self->{service} = $parent; + $self->{object_path} = $path; + } + + $self->{interface} = shift; + $self->{introspector} = undef; + $self->{introspected} = 0; + $self->{callbacks} = {}; + $self->{children} = {}; + + bless $self, $class; + + if ($self->{parent}->isa(__PACKAGE__)) { + $self->{parent}->_register_child($self); + } else { + $self->get_service->_register_object($self); + } + + return $self; +} + + +=item $object->disconnect(); + +This method disconnects the object from the bus, such that it +will no longer receive messages sent by other clients. Any +child objects will be recursively disconnected too. After an +object has been disconnected, it is possible for Perl to +garbage collect the object instance. It will also make it +possible to connect a newly created object to the same path. + +=cut + +sub disconnect { + my $self = shift; + + return unless $self->{parent}; + + foreach my $child (keys %{$self->{children}}) { + $self->_unregister_child($self->{children}->{$child}); + } + + if ($self->{parent}->isa(__PACKAGE__)) { + $self->{parent}->_unregister_child($self); + } else { + $self->get_service->_unregister_object($self); + } + $self->{parent} = undef; +} + +=item my $bool = $object->is_connected + +Returns a true value if the object is connected to the bus, +and thus capable of being accessed by remote clients. Returns +false if the object is disconnected & thus ready for garbage +collection. All objects start off in the connected state, and +will only transition if the C method is called. + +=cut + +sub is_connected { + my $self = shift; + + return 0 unless $self->{parent}; + + if ($self->{parent}->isa(__PACKAGE__)) { + return $self->{parent}->is_connected; + } + return 1; +} + +sub DESTROY { + my $self = shift; + # XXX there are some issues during global + # destruction which need to be better figured + # out before this will work + #$self->disconnect; +} + +sub _register_child { + my $self = shift; + my $object = shift; + + $self->get_service->_register_object($object); + $self->{children}->{$object->get_object_path} = $object; +} + + +sub _unregister_child { + my $self = shift; + my $object = shift; + + $self->get_service->_unregister_object($object); + delete $self->{children}->{$object->get_object_path}; +} + +# return a list of sub nodes for this object +sub _get_sub_nodes { + my $self = shift; + my %uniq; + + my $base = "$self->{object_path}/"; + foreach ( keys( %{$self->{children}} ) ) { + m/^$base([^\/]+)/; + $uniq{$1} = 1; + } + + return sort( keys( %uniq ) ); +} + +=item my $service = $object->get_service + +Retrieves the L object within which this +object is exported. + +=cut + +sub get_service { + my $self = shift; + return $self->{service}; +} + + +=item my $path = $object->get_object_path + +Retrieves the path under which this object is exported + +=cut + +sub get_object_path { + my $self = shift; + return $self->{object_path}; +} + +=item $object->emit_signal_in($name, $interface, $client, @args); + +Emits a signal from the object, with a name of C<$name>. If the +C<$interface> parameter is defined, the signal will be scoped +within that interface. If the C<$client> parameter is defined, +the signal will be unicast to that client on the bus. The +signal and the data types of the arguments C<@args> must have +been registered with L by calling the +C method. + +=cut + +sub emit_signal_in { + my $self = shift; + my $name = shift; + my $interface = shift; + my $destination = shift; + my @args = @_; + + die "object is disconnected from the bus" unless $self->is_connected; + + my $con = $self->get_service->get_bus->get_connection; + + my $signal = $con->make_signal_message($self->get_object_path, + $interface, + $name); + if ($destination) { + $signal->set_destination($destination); + } + + my $ins = $self->_introspector; + if ($ins) { + $ins->encode($signal, "signals", $name, "params", @args); + } else { + $signal->append_args_list(@args); + } + $con->send($signal); + + # Short circuit locally registered callbacks + if (exists $self->{callbacks}->{$interface} && + exists $self->{callbacks}->{$interface}->{$name}) { + my $cb = $self->{callbacks}->{$interface}->{$name}; + &$cb(@args); + } +} + +=item $self->emit_signal_to($name, $client, @args); + +Emits a signal from the object, with a name of C<$name>. The +signal and the data types of the arguments C<@args> must have +been registered with L by calling the +C method. The signal will be sent only to the +client named by the C<$client> parameter. + +=cut + +sub emit_signal_to { + my $self = shift; + my $name = shift; + my $destination = shift; + my @args = @_; + + my $intro = $self->_introspector; + if (!$intro) { + die "no introspection data available for '" . $self->get_object_path . + "', use the emit_signal_in method instead"; + } + my @interfaces = $intro->has_signal($name); + if ($#interfaces == -1) { + die "no signal with name '$name' is exported in object '" . + $self->get_object_path . "'\n"; + } elsif ($#interfaces > 0) { + die "signal '$name' is exported in more than one interface of '" . + $self->get_object_path . "', use the emit_signal_in method instead."; + } + $self->emit_signal_in($name, $interfaces[0], $destination, @args); +} + +=item $self->emit_signal($name, @args); + +Emits a signal from the object, with a name of C<$name>. The +signal and the data types of the arguments C<@args> must have +been registered with L by calling the +C method. The signal will be broadcast to all +clients on the bus. + +=cut + +sub emit_signal { + my $self = shift; + my $name = shift; + my @args = @_; + + $self->emit_signal_to($name, undef, @args); +} + +=item $object->connect_to_signal_in($name, $interface, $coderef); + +Connects a callback to a signal emitted by the object. The C<$name> +parameter is the name of the signal within the object, and C<$coderef> +is a reference to an anonymous subroutine. When the signal C<$name> +is emitted by the remote object, the subroutine C<$coderef> will be +invoked, and passed the parameters from the signal. The C<$interface> +parameter is used to specify the explicit interface defining the +signal to connect to. + +=cut + +sub connect_to_signal_in { + my $self = shift; + my $name = shift; + my $interface = shift; + my $code = shift; + + die "object is disconnected from the bus" unless $self->is_connected; + + $self->{callbacks}->{$interface} = {} unless + exists $self->{callbacks}->{$interface}; + $self->{callbacks}->{$interface}->{$name} = $code; +} + +=item $object->connect_to_signal($name, $coderef); + +Connects a callback to a signal emitted by the object. The C<$name> +parameter is the name of the signal within the object, and C<$coderef> +is a reference to an anonymous subroutine. When the signal C<$name> +is emitted by the remote object, the subroutine C<$coderef> will be +invoked, and passed the parameters from the signal. + +=cut + +sub connect_to_signal { + my $self = shift; + my $name = shift; + my $code = shift; + + my $ins = $self->_introspector; + if (!$ins) { + die "no introspection data available for '" . $self->get_object_path . + "', use the connect_to_signal_in method instead"; + } + my @interfaces = $ins->has_signal($name); + + if ($#interfaces == -1) { + die "no signal with name '$name' is exported in object '" . + $self->get_object_path . "'\n"; + } elsif ($#interfaces > 0) { + die "signal with name '$name' is exported " . + "in multiple interfaces of '" . $self->get_object_path . "'" . + "use the connect_to_signal_in method instead"; + } + + $self->connect_to_signal_in($name, $interfaces[0], $code); +} + + +sub _dispatch { + my $self = shift; + my $connection = shift; + my $message = shift; + + # Experiment in handling dispatch for child objects internally +# my $path = $message->get_path; +# while ($path ne $self->get_object_path) { +# if (exists $self->{children}->{$path}) { +# $self->{children}->{$path}->_dispatch($connection, $message); +# return; +# } +# $path =~ s,/[^/]+$,,; +# } + + my $reply; + my $method_name = $message->get_member; + my $interface = $message->get_interface; + if ((defined $interface) && + ($interface eq "org.freedesktop.DBus.Introspectable")) { + if ($method_name eq "Introspect" && + $self->_introspector && + $ENABLE_INTROSPECT) { + my $xml = $self->_introspector->format($self); + $reply = $connection->make_method_return_message($message); + + $self->_introspector->encode($reply, "methods", $method_name, "returns", $xml); + } + } elsif ((defined $interface) && + ($interface eq "org.freedesktop.DBus.Properties")) { + if ($method_name eq "Get") { + $reply = $self->_dispatch_prop_read($connection, $message); + } elsif ($method_name eq "GetAll") { + $reply = $self->_dispatch_all_prop_read($connection, $message); + } elsif ($method_name eq "Set") { + $reply = $self->_dispatch_prop_write($connection, $message); + } + } elsif ($self->_is_method_allowed($method_name)) { + my $ins = $self->_introspector; + my @ret = eval { + my @args; + if ($ins) { + @args = $ins->decode($message, "methods", $method_name, "params"); + } else { + @args = $message->get_args_list; + } + + $self->$method_name(@args); + }; + if ($@) { + my $name = UNIVERSAL::isa($@, "Net::DBus::Error") ? $@->name : "org.freedesktop.DBus.Error.Failed"; + my $desc = UNIVERSAL::isa($@, "Net::DBus::Error") ? $@->message : $@; + $reply = $connection->make_error_message($message, + $name, + $desc); + } else { + $reply = $connection->make_method_return_message($message); + if ($ins) { + $self->_introspector->encode($reply, "methods", $method_name, "returns", @ret); + } else { + $reply->append_args_list(@ret); + } + } + } + + if (!$reply) { + $reply = $connection->make_error_message($message, + "org.freedesktop.DBus.Error.Failed", + "No such method " . ref($self) . "->" . $method_name); + } + + if ($message->get_no_reply()) { + # Not sending reply + } else { + $self->get_service->get_bus->get_connection->send($reply); + } +} + + +sub _dispatch_prop_read { + my $self = shift; + my $connection = shift; + my $message = shift; + + my $ins = $self->_introspector; + + if (!$ins) { + return $connection->make_error_message($message, + "org.freedesktop.DBus.Error.Failed", + "no introspection data exported for properties"); + } + + my ($pinterface, $pname) = $ins->decode($message, "methods", "Get", "params"); + + if (!$ins->has_property($pname, $pinterface)) { + return $connection->make_error_message($message, + "org.freedesktop.DBus.Error.Failed", + "no property '$pname' exported in interface '$pinterface'"); + } + + if (!$ins->is_property_readable($pinterface, $pname)) { + return $connection->make_error_message($message, + "org.freedesktop.DBus.Error.Failed", + "property '$pname' in interface '$pinterface' is not readable"); + } + + if ($self->can($pname)) { + my $value = eval { + $self->$pname; + }; + if ($@) { + return $connection->make_error_message($message, + "org.freedesktop.DBus.Error.Failed", + "error reading '$pname' in interface '$pinterface': $@"); + } else { + my $reply = $connection->make_method_return_message($message); + + $self->_introspector->encode($reply, "methods", "Get", "returns", $value); + return $reply; + } + } else { + return $connection->make_error_message($message, + "org.freedesktop.DBus.Error.Failed", + "no method to read property '$pname' in interface '$pinterface'"); + } +} + +sub _dispatch_all_prop_read { + my $self = shift; + my $connection = shift; + my $message = shift; + + my $ins = $self->_introspector; + + if (!$ins) { + return $connection->make_error_message($message, + "org.freedesktop.DBus.Error.Failed", + "no introspection data exported for properties"); + } + + my ($pinterface) = $ins->decode($message, "methods", "Get", "params"); + + my %values = (); + foreach my $pname ($ins->list_properties($pinterface)) { + unless ($ins->is_property_readable($pinterface, $pname)) { + next; # skip write-only properties + } + + $values{$pname} = eval { + $self->$pname; + }; + if ($@) { + return $connection->make_error_message($message, + "org.freedesktop.DBus.Error.Failed", + "error reading '$pname' in interface '$pinterface': $@"); + } + } + + my $reply = $connection->make_method_return_message($message); + + $self->_introspector->encode($reply, "methods", "Get", "returns", \%values); + return $reply; +} + +sub _dispatch_prop_write { + my $self = shift; + my $connection = shift; + my $message = shift; + + my $ins = $self->_introspector; + + if (!$ins) { + return $connection->make_error_message($message, + "org.freedesktop.DBus.Error.Failed", + "no introspection data exported for properties"); + } + + my ($pinterface, $pname, $pvalue) = $ins->decode($message, "methods", "Set", "params"); + + if (!$ins->has_property($pname, $pinterface)) { + return $connection->make_error_message($message, + "org.freedesktop.DBus.Error.Failed", + "no property '$pname' exported in interface '$pinterface'"); + } + + if (!$ins->is_property_writable($pinterface, $pname)) { + return $connection->make_error_message($message, + "org.freedesktop.DBus.Error.Failed", + "property '$pname' in interface '$pinterface' is not writable"); + } + + if ($self->can($pname)) { + eval { + $self->$pname($pvalue); + }; + if ($@) { + return $connection->make_error_message($message, + "org.freedesktop.DBus.Error.Failed", + "error writing '$pname' in interface '$pinterface': $@"); + } else { + return $connection->make_method_return_message($message); + } + } else { + return $connection->make_error_message($message, + "org.freedesktop.DBus.Error.Failed", + "no method to write property '$pname' in interface '$pinterface'"); + } +} + + +sub _introspector { + my $self = shift; + + if (!$self->{introspected}) { + $self->{introspector} = Net::DBus::Exporter::_dbus_introspector(ref($self)); + $self->{introspected} = 1; + } + return $self->{introspector}; +} + +sub _is_method_allowed { + my $self = shift; + my $method = shift; + + # Disallow any method defined in this specific package, since these + # are all server-side helpers / internal methods + return 0 if __PACKAGE__->can($method); + + # If this object instance doesn't have it defined, trivially can't + # allow it + return 0 unless $self->can($method); + + my $ins = $self->_introspector; + if (defined $ins) { + # Finally do check against introspection data + return $ins->is_method_allowed($method); + } + + # No introspector, so have to assume its allowed + return 1; +} + +1; + + +=pod + +=back + +=head1 AUTHOR + +Daniel P. Berrange + +=head1 COPYRIGHT + +Copyright (C) 2005-2011 Daniel P. Berrange + +=head1 SEE ALSO + +L, L, L, +L. + +=cut diff --git a/lib/Net/DBus/Reactor.pm b/lib/Net/DBus/Reactor.pm new file mode 100644 index 0000000..1f7d5cf --- /dev/null +++ b/lib/Net/DBus/Reactor.pm @@ -0,0 +1,799 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Reactor - application event loop + +=head1 SYNOPSIS + +Create and run an event loop: + + use Net::DBus::Reactor; + my $reactor = Net::DBus::Reactor->main(); + + $reactor->run(); + +Manage some file handlers + + $reactor->add_read($fd, + Net::DBus::Callback->new(method => sub { + my $fd = shift; + ...read some data... + }, args => [$fd])); + + $reactor->add_write($fd, + Net::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, + Net::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(Net::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 Net::DBus::Reactor; + +use 5.006; +use strict; +use warnings; + +use Net::DBus::Binding::Watch; +use Net::DBus::Callback; +use Time::HiRes qw(gettimeofday); + +=item my $reactor = Net::DBus::Reactor->new(); + +Creates a new event loop ready for monitoring file handles, or +generating timeouts. Except in very unsual circumstances (examples +of which I can't think up) it is not neccessary or desriable to +explicitly create new reactor instances. Instead call the L
+method to get a handle to the singleton instance. + +=cut + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my %params = @_; + my $self = {}; + + $self->{fds} = { + read => {}, + write => {}, + exception => {} + }; + $self->{timeouts} = []; + $self->{hooks} = []; + + bless $self, $class; + + return $self; +} + +use vars qw($main_reactor); + +=item $reactor = Net::DBus::Reactor->main; + +Return a handle to the singleton instance of the reactor. This +is the recommended way of getting hold of a reactor, since it +removes the need for modules to pass around handles to their +privately created reactors. + +=cut + +sub main { + my $class = shift; + $main_reactor = $class->new() unless defined $main_reactor; + return $main_reactor; +} + + +=item $reactor->manage($connection); + +=item $reactor->manage($server); + +Registers a C or C 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 method periodically. + +=cut + +sub manage { + my $self = 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); + }); + } + + 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, + Net::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(Net::DBus::Callback->new(object => $object, + method => "dispatch", + args => []), + 1); + } + if ($object->can("flush")) { + $self->add_hook(Net::DBus::Callback->new(object => $object, + method => "flush", + args => []), + 1); + } +} + + +sub _manage_watch_on { + my $self = shift; + my $object = shift; + my $watch = shift; + my $flags = $watch->get_flags; + + if ($flags & &Net::DBus::Binding::Watch::READABLE) { + $self->add_read($watch->get_fileno, + Net::DBus::Callback->new(object => $watch, + method => "handle", + args => [&Net::DBus::Binding::Watch::READABLE]), + $watch->is_enabled); + } + if ($flags & &Net::DBus::Binding::Watch::WRITABLE) { + $self->add_write($watch->get_fileno, + Net::DBus::Callback->new(object => $watch, + method => "handle", + args => [&Net::DBus::Binding::Watch::WRITABLE]), + $watch->is_enabled); + } +# $self->add_exception($watch->get_fileno, $watch, +# Net::DBus::Callback->new(object => $watch, +# method => "handle", +# args => [&Net::DBus::Binding::Watch::ERROR]), +# $watch->is_enabled); + +} + +sub _manage_watch_off { + my $self = shift; + my $object = shift; + my $watch = shift; + my $flags = $watch->get_flags; + + if ($flags & &Net::DBus::Binding::Watch::READABLE) { + $self->remove_read($watch->get_fileno); + } + if ($flags & &Net::DBus::Binding::Watch::WRITABLE) { + $self->remove_write($watch->get_fileno); + } +# $self->remove_exception($watch->get_fileno); +} + +sub _manage_watch_toggle { + my $self = shift; + my $object = shift; + my $watch = shift; + my $flags = $watch->get_flags; + + if ($flags & &Net::DBus::Binding::Watch::READABLE) { + $self->toggle_read($watch->get_fileno, $watch->is_enabled); + } + if ($flags & &Net::DBus::Binding::Watch::WRITABLE) { + $self->toggle_write($watch->get_fileno, $watch->is_enabled); + } + $self->toggle_exception($watch->get_fileno, $watch->is_enabled); +} + + +=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 method. + +=cut + +sub run { + my $self = shift; + + $self->{running} = 1; + while ($self->{running}) { $self->step }; +} + +=item $reactor->shutdown(); + +Explicitly shutdown the reactor after pending +events have been processed. + +=cut + +sub shutdown { + my $self = shift; + $self->{running} = 0; +} + +=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 @callbacks = $self->_dispatch_hook(); + + foreach my $callback (@callbacks) { + $callback->invoke; + } + + my ($ri, $ric) = $self->_bits("read"); + my ($wi, $wic) = $self->_bits("write"); + my ($ei, $eic) = $self->_bits("exception"); + my $timeout = $self->_timeout($self->_now); + + if (!$ric && !$wic && !$eic && !(defined $timeout)) { + $self->{running} = 0; + } + + # One of the hooks we ran might have requested shutdown + # so check here to avoid a undesirable wait in select() + # cf RT #39068 + return unless $self->{running}; + + my ($ro, $wo, $eo); + my $n = select($ro=$ri,$wo=$wi,$eo=$ei, (defined $timeout ? ($timeout ? $timeout/1000 : 0) : undef)); + + @callbacks = (); + if ($n) { + 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; + my $vec = ''; + + my $count = 0; + foreach (keys %{$self->{fds}->{$type}}) { + next unless $self->{fds}->{$type}->{$_}->{enabled}; + + $count++; + vec($vec, $_, 1) = 1; + } + return ($vec, $count); +} + +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}; + + push @callbacks, $self->{fds}->{$type}->{$fd}->{callback}; + } + } + return @callbacks; +} + + +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; +} + + +=item $reactor->add_read($fd, $callback[, $status]); + +Registers a file handle for monitoring of read +events. The C<$callback> parameter specifies either +a code reference to a subroutine, or an instance of +the C 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", @_); +} + +=item $reactor->add_write($fd, $callback[, $status]); + +Registers a file handle for monitoring of write +events. The C<$callback> parameter specifies either +a code reference to a subroutine, or an +instance of the C 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", @_); +} + + +=item $reactor->add_exception($fd, $callback[, $status]); + +Registers a file handle for monitoring of exception +events. The C<$callback> parameter specifies either +a code reference to a subroutine, or an +instance of the C 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", @_); +} + + +=item my $id = $reactor->add_timeout($interval, $callback, $status); + +Registers a new timeout to expire every C<$interval> +milliseconds. The C<$callback> parameter specifies either +a code reference to a subroutine, or an +instance of the C 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; + + if (ref($callback) eq "CODE") { + $callback = Net::DBus::Callback->new(method => $callback); + } + + 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; +} + + +=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; + + die "no timeout active with key '$key'" + unless defined $self->{timeouts}->[$key]; + + $self->{timeouts}->[$key] = undef; +} + + +=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 @_; +} + + +=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 either a code reference to a subroutine, or +an instance of the C +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; + + if (ref($callback) eq "CODE") { + $callback = Net::DBus::Callback->new(method => $callback); + } + + 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; +} + + +=item $reactor->remove_hook($id) + +Removes the previously registered hook identified +by C<$id>. + +=cut + +sub remove_hook { + my $self = shift; + my $key = shift; + + die "no hook present with key '$key'" + unless defined $self->{hooks}->[$key]; + + + $self->{hooks}->[$key] = undef; +} + +=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 $callback = shift; + my $enabled = shift; + $enabled = 1 unless defined $enabled; + + if (ref($callback) eq "CODE") { + $callback = Net::DBus::Callback->new(method => $callback); + } + + $self->{fds}->{$type}->{$fd} = { + callback => $callback, + enabled => $enabled + }; +} + +=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", @_); +} + +sub remove_write { + my $self = shift; + $self->_remove("write", @_); +} + +sub remove_exception { + my $self = shift; + $self->_remove("exception", @_); +} + +sub _remove { + my $self = shift; + my $type = shift; + my $fd = shift; + + die "no handle ($type) active with fd '$fd'" + unless exists $self->{fds}->{$type}->{$fd}; + + delete $self->{fds}->{$type}->{$fd}; +} + +=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", @_); +} + +sub toggle_write { + my $self = shift; + $self->_toggle("write", @_); +} + +sub toggle_exception { + my $self = shift; + $self->_toggle("exception", @_); +} + +sub _toggle { + my $self = shift; + my $type = shift; + my $fd = shift; + my $enabled = shift; + + $self->{fds}->{$type}->{$fd}->{enabled} = $enabled; +} + + +1; + +=pod + +=back + +=head1 SEE ALSO + +L, L, L + +=head1 AUTHOR + +Daniel Berrange Edan@berrange.comE + +=head1 COPYRIGHT + +Copyright 2004-2011 by Daniel Berrange + +=cut diff --git a/lib/Net/DBus/RemoteObject.pm b/lib/Net/DBus/RemoteObject.pm new file mode 100644 index 0000000..bd7f153 --- /dev/null +++ b/lib/Net/DBus/RemoteObject.pm @@ -0,0 +1,493 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::RemoteObject - Access objects provided on the bus + +=head1 SYNOPSIS + + my $service = $bus->get_service("org.freedesktop.DBus"); + my $object = $service->get_object("/org/freedesktop/DBus"); + + print "Names on the bus {\n"; + foreach my $name (sort @{$object->ListNames}) { + print " ", $name, "\n"; + } + print "}\n"; + +=head1 DESCRIPTION + +This module provides the API for accessing remote objects available +on the bus. It uses the autoloader to fake the presence of methods +based on the API of the remote object. There is also support for +setting callbacks against signals, and accessing properties of the +object. + +=head1 METHODS + +=over 4 + +=cut + +package Net::DBus::RemoteObject; + +use 5.006; +use strict; +use warnings; + +our $AUTOLOAD; + +use Net::DBus::Binding::Introspector; +use Net::DBus::ASyncReply; +use Net::DBus::Annotation qw(:call); + + +=item my $object = Net::DBus::RemoteObject->new($service, $object_path[, $interface]); + +Creates a new handle to a remote object. The C<$service> parameter is an instance +of the L method, and C<$object_path> is the identifier of +an object exported by this service, for example C. For remote +objects which implement more than one interface it is possible to specify an optional +name of an interface as the third parameter. This is only really required, however, if +two interfaces in the object provide methods with the same name, since introspection +data can be used to automatically resolve the correct interface to call cases where +method names are unique. Rather than using this constructor directly, it is preferrable +to use the C method on L, since this caches handles +to remote objects, eliminating unneccessary introspection data lookups. + +=cut + + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = {}; + + $self->{service} = shift; + $self->{object_path} = shift; + $self->{interface} = @_ ? shift : undef; + $self->{introspected} = 0; + $self->{signal_handlers} = {}; + $self->{signal_id} = 0; + + bless $self, $class; + + return $self; +} + +=item my $object = $object->as_interface($interface); + +Casts the object to a specific interface, returning a new instance of the +L specialized to the desired interface. It is only +neccessary to cast objects to a specific interface, if two interfaces +export methods or signals with the same name, or the remote object does not +support introspection. + +=cut + +sub as_interface { + my $self = shift; + my $interface = shift; + + die "already cast to " . $self->{interface} . "'" + if $self->{interface}; + + return $self->new($self->{service}, + $self->{object_path}, + $interface); +} + +=item my $service = $object->get_service + +Retrieves a handle for the remote service on which this object is +attached. The returned object is an instance of L + +=cut + +sub get_service { + my $self = shift; + return $self->{service}; +} + +=item my $path = $object->get_object_path + +Retrieves the unique path identifier for this object within the +service. + +=cut + +sub get_object_path { + my $self = shift; + return $self->{object_path}; +} + +=item my $object = $object->get_child_object($subpath, [$interface]) + +Retrieves a handle to a child of this object, identified +by the relative path C<$subpath>. The returned object +is an instance of C. The optional +C<$interface> parameter can be used to immediately cast +the object to a specific type. + +=cut + +sub get_child_object { + my $self = shift; + my $path = shift; + my $interface = @_ ? shift : undef; + my $fullpath = $self->{object_path} . $path; + + return $self->new($self->get_service, + $fullpath, + $interface); +} + +sub _introspector { + my $self = shift; + + + unless ($self->{introspected}) { + my $con = $self->{service}->get_bus()->get_connection(); + + my $call = $con->make_method_call_message($self->{service}->get_service_name(), + $self->{object_path}, + "org.freedesktop.DBus.Introspectable", + "Introspect"); + + my $xml = eval { + my $reply = $con->send_with_reply_and_block($call, 60 * 1000); + + my $iter = $reply->iterator; + return $iter->get(&Net::DBus::Binding::Message::TYPE_STRING); + }; + if ($@) { + if (UNIVERSAL::isa($@, "Net::DBus::Error") && + $@->{name} eq "org.freedesktop.DBus.Error.ServiceUnknown") { + die $@; + } else { + # Ignore other failures, since its probably + # just that the object doesn't implement + # the introspect method. Of course without + # the introspect method we can't tell for sure + # if this is the case.. + #warn "could not introspect object: $@"; + } + } + if ($xml) { + $self->{introspector} = Net::DBus::Binding::Introspector->new(xml => $xml, + object_path => $self->{object_path}); + } + $self->{introspected} = 1; + } + return $self->{introspector}; +} + + +=item my $sigid = $object->connect_to_signal($name, $coderef); + +Connects a callback to a signal emitted by the object. The C<$name> +parameter is the name of the signal within the object, and C<$coderef> +is a reference to an anonymous subroutine. When the signal C<$name> +is emitted by the remote object, the subroutine C<$coderef> will be +invoked, and passed the parameters from the signal. A unique C<$sigid> +will be returned, which can be later passed to C +to remove the handler + +=cut + +sub connect_to_signal { + my $self = shift; + my $name = shift; + my $code = shift; + + my $ins = $self->_introspector; + my $interface = $self->{interface}; + if (!$interface) { + if (!$ins) { + die "no introspection data available for '" . $self->get_object_path . + "', and object is not cast to any interface"; + } + my @interfaces = $ins->has_signal($name); + + if ($#interfaces == -1) { + die "no signal with name '$name' is exported in object '" . + $self->get_object_path . "'\n"; + } elsif ($#interfaces > 0) { + warn "signal with name '$name' is exported " . + "in multiple interfaces of '" . $self->get_object_path . "'" . + "connecting to first interface only\n"; + } + $interface = $interfaces[0]; + } + + if ($ins && + $ins->has_signal($name, $interface) && + $ins->is_signal_deprecated($name, $interface)) { + warn "signal $name in interface $interface on " . $self->get_object_path . " is deprecated"; + } + + my $cb = sub { + my $signal = shift; + my $ins = $self->_introspector; + my @params; + if ($ins) { + @params = $ins->decode($signal, "signals", $signal->get_member, "params"); + } else { + @params = $signal->get_args_list; + } + + foreach my $handler (@{$self->{signal_handlers}->{$signal->get_member}->{handlers}}) { + my ($id, $cb) = @{$handler}; + &$cb(@params); + } + }; + if (!exists $self->{signal_handlers}->{$name}) { + $self->{signal_handlers}->{$name} = { cb => $cb, handlers => [] }; + $self->get_service-> + get_bus()-> + _add_signal_receiver($cb, + $name, + $interface, + $self->{service}->get_service_name(), + $self->{object_path}); + } + my $sigid = ++$self->{signal_id}; + push @{$self->{signal_handlers}->{$name}->{handlers}}, [$sigid, $code]; + return $sigid; +} + + +=item $object->disconnect_from_signal($name, $sigid); + +Disconnects from a signal emitted by the object. The C<$name> +parameter is the name of the signal within the object. The +C<$sigid> must be the unique signal handler ID returned by +a previous C method call. + +=cut + +sub disconnect_from_signal { + my $self = shift; + my $name = shift; + my $sigid = shift; + + my $ins = $self->_introspector; + my $interface = $self->{interface}; + if (!$interface) { + if (!$ins) { + die "no introspection data available for '" . $self->get_object_path . + "', and object is not cast to any interface"; + } + my @interfaces = $ins->has_signal($name); + + if ($#interfaces == -1) { + die "no signal with name '$name' is exported in object '" . + $self->get_object_path . "'\n"; + } elsif ($#interfaces > 0) { + warn "signal with name '$name' is exported " . + "in multiple interfaces of '" . $self->get_object_path . "'" . + "connecting to first interface only\n"; + } + $interface = $interfaces[0]; + } + + my @handlers; + foreach my $handler (@{$self->{signal_handlers}->{$name}->{handlers}}) { + my ($thissigid, $cb) = @{$handler}; + if ($thissigid != $sigid) { + push @handlers, $handler; + } + } + if (@handlers) { + $self->{signal_handlers}->{$name}->{handlers} = \@handlers; + } else { + $self->get_service-> + get_bus()-> + _remove_signal_receiver($self->{signal_handlers}->{$name}->{cb}, + $name, + $interface, + $self->{service}->get_service_name(), + $self->{object_path}); + delete $self->{signal_handlers}->{$name}; + } +} + + +sub DESTROY { + # No op merely to stop AutoLoader trying to + # call DESTROY on remote object +} + +sub AUTOLOAD { + my $self = shift; + my $sub = $AUTOLOAD; + + my $mode = dbus_call_sync; + if (@_ && UNIVERSAL::isa($_[0], "Net::DBus::Annotation")) { + $mode = shift; + } + + (my $name = $AUTOLOAD) =~ s/.*:://; + + my $interface = $self->{interface}; + + # If introspection data is available, use that + # to resolve correct interface (if object is not + # cast to an explicit interface already) + my $ins = $self->_introspector(); + if ($ins) { + if ($interface) { + if ($ins->has_method($name, $interface)) { + return $self->_call_method($mode, $name, $interface, 1, @_); + } + if ($ins->has_property($name, $interface)) { + if ($ins->is_property_deprecated($name, $interface)) { + warn "property $name in interface $interface on " . $self->get_object_path . " is deprecated"; + } + + if (@_) { + $self->_call_method($mode, "Set", "org.freedesktop.DBus.Properties", $interface, 1, $name, $_[0]); + return (); + } else { + return $self->_call_method($mode, "Get", "org.freedesktop.DBus.Properties", $interface, 1, $name); + } + } + } else { + my @interfaces = $ins->has_method($name); + + if (@interfaces) { + if ($#interfaces > 0) { + die "method with name '$name' is exported " . + "in multiple interfaces of '" . $self->get_object_path . "'"; + } + return $self->_call_method($mode, $name, $interfaces[0], 1, @_); + } + @interfaces = $ins->has_property($name); + + if (@interfaces) { + if ($#interfaces > 0) { + die "property with name '$name' is exported " . + "in multiple interfaces of '" . $self->get_object_path . "'"; + } + $interface = $interfaces[0]; + if ($ins->is_property_deprecated($name, $interface)) { + warn "property $name in interface $interface on " . $self->get_object_path . " is deprecated"; + } + if (@_) { + $self->_call_method($mode, "Set", "org.freedesktop.DBus.Properties", $interface, 1, $name, $_[0]); + return (); + } else { + return $self->_call_method($mode, "Get", "org.freedesktop.DBus.Properties", $interface, 1, $name); + } + } + } + } + + if (!$interface) { + die "no introspection data available for method '" . $name . "' in object '" . + $self->get_object_path . "', and object is not cast to any interface"; + } + + return $self->_call_method($mode, $name, $interface, 0, @_); +} + + +sub _call_method { + my $self = shift; + my $mode = shift; + my $name = shift; + my $interface = shift; + my $introspect = shift; + + my $con = $self->{service}->get_bus()->get_connection(); + + my $ins = $introspect ? $self->_introspector : undef; + if ($ins && + $ins->is_method_deprecated($name, $interface)) { + warn "method '$name' in interface $interface on object " . $self->get_object_path . " is deprecated\n"; + } + + my $call = $con->make_method_call_message($self->{service}->get_service_name(), + $self->{object_path}, + $interface, + $name); + + #$call->set_destination($self->get_service->get_owner_name); + + if ($ins) { + $ins->encode($call, "methods", $name, "params", @_); + } else { + $call->append_args_list(@_); + } + + if ($mode == dbus_call_sync) { + my $reply = $con-> + send_with_reply_and_block($call, 60 * 1000); + + my @reply; + if ($ins) { + @reply = $ins->decode($reply, "methods", $name, "returns"); + } else { + @reply = $reply->get_args_list; + } + + return wantarray ? @reply : $reply[0]; + } elsif ($mode == dbus_call_async) { + my $pending_call = $self->{service}-> + get_bus()-> + get_connection()-> + send_with_reply($call, 60 * 1000); + my $reply = Net::DBus::ASyncReply->_new(pending_call => $pending_call, + ($ins ? (introspector => $ins, + method_name => $name) + : ())); + return $reply; + } elsif ($mode == dbus_call_noreply) { + $call->set_no_reply(1); + $self->{service}-> + get_bus()-> + get_connection()-> + send($call, 60 * 1000); + } else { + die "unsupported annotation '$mode'"; + } +} + + +1; + +=pod + +=back + +=head1 AUTHOR + +Daniel Berrange + +=head1 COPYRIGHT + +Copright (C) 2004-2011, Daniel Berrange. + +=head1 SEE ALSO + +L, L + +=cut diff --git a/lib/Net/DBus/RemoteService.pm b/lib/Net/DBus/RemoteService.pm new file mode 100644 index 0000000..6ab8068 --- /dev/null +++ b/lib/Net/DBus/RemoteService.pm @@ -0,0 +1,171 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::RemoteService - Access services provided on the bus + +=head1 SYNOPSIS + + my $bus = Net::DBus->find; + my $service = $bus->get_service("org.freedesktop.DBus"); + + my $object = $service->get_object("/org/freedesktop/DBus"); + foreach (@{$object->ListNames}) { + print "$_\n"; + } + +=head1 DESCRIPTION + +This object provides a handle to a remote service on the +bus. From this handle it is possible to access objects +associated with the service. If a service is not running, +an attempt will be made to activate it the first time a +method is called against one of its objects. + +=head1 METHODS + +=over 4 + +=cut + +package Net::DBus::RemoteService; + +use 5.006; +use strict; +use warnings; + +use Net::DBus::RemoteObject; + +=item my $service = Net::DBus::RemoteService->new($bus, $owner, $service_name); + +Creates a new handle for a remote service. The C<$bus> parameter is an +instance of L, C<$owner> is the name of the client providing the +service, while C<$service_name> is the well known name of the service on +the bus. Service names consist of two or more tokens, separated +by periods, while the tokens comprise the letters a-z, A-Z, 0-9 and _, +for example C. There is generally no need to call +this constructor, instead the C method on L should +be used. This caches handles to remote services, eliminating repeated +retrieval of introspection data. + +=cut + +sub new { + my $class = shift; + my $self = {}; + + $self->{bus} = shift; + $self->{owner_name} = shift; + $self->{service_name} = shift; + $self->{objects} = {}; + + bless $self, $class; + + return $self; +} + + +=item my $bus = $service->get_bus; + +Retrieves a handle for the bus to which this service is attached. +The returned object will be an instance of L. + +=cut + +sub get_bus { + my $self = shift; + + return $self->{bus}; +} + + +=item my $service_name = $service->get_service_name + +Retrieves the name of the remote service as known to the bus. + +=cut + +sub get_service_name { + my $self = shift; + return $self->{service_name}; +} + +=item my $owner_name = $service->get_owner_name; + +Retrieves the name of the client owning the service at the +time it was connected to. + +=cut + +sub get_owner_name { + my $self = shift; + return $self->{owner_name}; +} + +=item my $object = $service->get_object($object_path[, $interface]); + +Retrieves a handle to the remote object provided by the service with +the name of C<$object_path>. If the optional C<$interface> parameter is +provided, the object will immediately be cast to the designated +interface. NB, it is only neccessary to cast an object to a specific +interface if there are multiple interfaces on the object providing +methods with the same name, or the remote object does support +introspection. The returned object will be an instance of L. + +=cut + +sub get_object { + my $self = shift; + my $object_path = shift; + + unless (defined $self->{objects}->{$object_path}) { + $self->{objects}->{$object_path} = Net::DBus::RemoteObject->new($self, + $object_path); + } + + if (@_) { + my $interface = shift; + return $self->{objects}->{$object_path}->as_interface($interface); + } else { + return $self->{objects}->{$object_path}; + } +} + +1; + + +=pod + +=back + +=head1 AUTHOR + +Daniel Berrange + +=head1 COPYRIGHT + +Copright (C) 2004-2011, Daniel Berrange. + +=head1 SEE ALSO + +L, L, L + +=cut diff --git a/lib/Net/DBus/Service.pm b/lib/Net/DBus/Service.pm new file mode 100644 index 0000000..adfd767 --- /dev/null +++ b/lib/Net/DBus/Service.pm @@ -0,0 +1,159 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Service - Provide a service to the bus for clients to use + +=head1 SYNOPSIS + + package main; + + use Net::DBus; + + # Attach to the bus + my $bus = Net::DBus->find; + + # Acquire a service 'org.demo.Hello' + my $service = $bus->export_service("org.demo.Hello"); + + # Export our object within the service + my $object = Demo::HelloWorld->new($service); + + ....rest of program... + +=head1 DESCRIPTION + +This module represents a service which is exported to the message +bus. Once a service has been exported, it is possible to create +and export objects to the bus. + +=head1 METHODS + +=over 4 + +=cut + + +package Net::DBus::Service; + +use 5.006; +use strict; +use warnings; + +=item my $service = Net::DBus::Service->new($bus, $name); + +Create a new service, attaching to the bus provided in +the C<$bus> parameter, which should be an instance of +the L object. The C<$name> parameter is the +qualified service name. It is not usually neccessary to +use this constructor, since services can be created via +the C method on the L object. + +=cut + +sub new { + my $class = shift; + my $self = {}; + + $self->{bus} = shift; + $self->{service_name} = shift; + $self->{objects} = {}; + + bless $self, $class; + + $self->get_bus->get_connection->request_name($self->get_service_name); + + return $self; +} + +=item my $bus = $service->get_bus; + +Retrieves the L object to which this service is +attached. + +=cut + +sub get_bus { + my $self = shift; + return $self->{bus}; +} + +=item my $name = $service->get_service_name + +Retrieves the qualified name by which this service is +known on the bus. + +=cut + +sub get_service_name { + my $self = shift; + return $self->{service_name}; +} + + +sub _register_object { + my $self = shift; + my $object = shift; + #my $wildcard = shift || 0; + +# if ($wildcard) { +# $self->get_bus->get_connection-> +# register_fallback($object->get_object_path, +# sub { +# $object->_dispatch(@_); +# }); +# } else { + $self->get_bus->get_connection-> + register_object_path($object->get_object_path, + sub { + $object->_dispatch(@_); + }); +# } +} + + +sub _unregister_object { + my $self = shift; + my $object = shift; + + $self->get_bus->get_connection-> + unregister_object_path($object->get_object_path); +} + +1; + +=pod + +=back + +=head1 AUTHOR + +Daniel P. Berrange + +=head1 COPYRIGHT + +Copyright (C) 2005-2011 Daniel P. Berrange + +=head1 SEE ALSO + +L, L, L + +=cut diff --git a/lib/Net/DBus/Test/MockConnection.pm b/lib/Net/DBus/Test/MockConnection.pm new file mode 100644 index 0000000..8682668 --- /dev/null +++ b/lib/Net/DBus/Test/MockConnection.pm @@ -0,0 +1,464 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Test::MockConnection - Fake a connection to the bus unit testing + +=head1 SYNOPSIS + + use Net::DBus; + + my $bus = Net::DBus->test + + # Register a service, and the objec to be tested + use MyObject + my $service = $bus->export_service("org.example.MyService"); + my $object = MyObject->new($service); + + + # Acquire the service & do tests + my $remote_service = $bus->get_service('org.example.MyService'); + my $remote_object = $service->get_object("/org/example/MyObjct"); + + # This traverses the mock connection, eventually + # invoking 'testSomething' on the $object above. + $remote_object->testSomething() + +=head1 DESCRIPTION + +This object provides a fake implementation of the L +enabling a pure 'in-memory' message bus to be mocked up. This is intended to +facilitate creation of unit tests for services which would otherwise need to +call out to other object on a live message bus. It is used as a companion to +the L module which is how fake objects are to be +provided on the fake bus. + +=head1 METHODS + +=over 4 + +=cut + +package Net::DBus::Test::MockConnection; + +use strict; +use warnings; + +use Net::DBus::Error; +use Net::DBus::Test::MockMessage; +use Net::DBus::Binding::Message::MethodCall; +use Net::DBus::Binding::Message::MethodReturn; +use Net::DBus::Binding::Message::Error; +use Net::DBus::Binding::Message::Signal; + +=item my $con = Net::DBus::Test::MockConnection->new() + +Create a new mock connection object instance. It is not usually +neccessary to create instances of this object directly, instead +the C method on the L object can be used to +get a handle to a test bus. + +=cut + +sub new { + my $class = shift; + my $self = {}; + + $self->{replies} = []; + $self->{signals} = []; + $self->{objects} = {}; + $self->{objectTrees} = {}; + $self->{filters} = []; + + bless $self, $class; + + return $self; +} + +=item $con->send($message) + +Send a message over the mock connection. If the message is +a method call, it will be dispatched straight to any corresponding +mock object registered. If the mesage is an error or method return +it will be made available as a return value for the C +method. If the message is a signal it will be queued up for processing +by the C method. + +=cut + + +sub send { + my $self = shift; + my $msg = shift; + + if ($msg->get_type() == &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_CALL) { + $self->_call_method($msg); + } elsif ($msg->get_type() == &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN || + $msg->get_type() == &Net::DBus::Binding::Message::MESSAGE_TYPE_ERROR) { + push @{$self->{replies}}, $msg; + } elsif ($msg->get_type() == &Net::DBus::Binding::Message::MESSAGE_TYPE_SIGNAL) { + push @{$self->{signals}}, $msg; + } else { + die "unhandled type of message " . ref($msg); + } +} + + +=item $bus->request_name($service_name) + +Pretend to send a request to the bus registering the well known +name specified in the C<$service_name> parameter. In reality +this is just a no-op giving the impression that the name was +successfully registered. + +=cut + +sub request_name { + my $self = shift; + my $name = shift; + my $flags = shift; + + # XXX do we care about this for test cases? probably not... + # ....famous last words +} + +=item my $reply = $con->send_with_reply_and_block($msg) + +Send a message over the mock connection and wait for a +reply. The C<$msg> should be an instance of C +and the return C<$reply> will be an instance of C. +It is also possible that an error will be thrown, with +the thrown error being blessed into the C +class. + +=cut + +sub send_with_reply_and_block { + my $self = shift; + my $msg = shift; + my $timeout = shift; + + $self->send($msg); + + if ($#{$self->{replies}} == -1) { + die "no reply for " . $msg->get_path . "->" . $msg->get_member . " received within timeout"; + } + + my $reply = shift @{$self->{replies}}; + if ($#{$self->{replies}} != -1) { + die "too many replies received"; + } + + if ($reply->get_type() == &Net::DBus::Binding::Message::MESSAGE_TYPE_ERROR) { + my $iter = $reply->iterator; + my $desc = $iter->get_string; + die Net::DBus::Error->new(name => $reply->get_error_name, + message => $desc); + } + + return $reply; +} + +=item $con->dispatch; + +Dispatches any pending messages in the incoming queue +to their message handlers. This method should be called +by test suites whenever they anticipate that there are +pending signals to be dealt with. + +=cut + +sub dispatch { + my $self = shift; + + my @signals = @{$self->{signals}}; + $self->{signals} = []; + foreach my $msg (@signals) { + foreach my $cb (@{$self->{filters}}) { + # XXX we should worry about return value... + &$cb($self, $msg); + } + } +} + +=item $con->add_filter($coderef); + +Adds a filter to the connection which will be invoked whenever a +message is received. The C<$coderef> should be a reference to a +subroutine, which returns a true value if the message should be +filtered out, or a false value if the normal message dispatch +should be performed. + +=cut + +sub add_filter { + my $self = shift; + my $cb = shift; + + push @{$self->{filters}}, $cb; +} + +=item $bus->add_match($rule) + +Register a signal match rule with the bus controller, allowing +matching broadcast signals to routed to this client. In reality +this is just a no-op giving the impression that the match was +successfully registered. + +=cut + +sub add_match { + my $self = shift; + my $rule = shift; + + # XXX do we need to implement anything ? probably not + # nada +} + +=item $bus->remove_match($rule) + +Unregister a signal match rule with the bus controller, preventing +further broadcast signals being routed to this client. In reality +this is just a no-op giving the impression that the match was +successfully unregistered. + +=cut + +sub remove_match { + my $self = shift; + my $rule = shift; + + # XXX do we need to implement anything ? probably not + # nada +} + + +=item $con->register_object_path($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 class). + +=cut + +sub register_object_path { + my $self = shift; + my $path = shift; + my $code = shift; + + $self->{objects}->{$path} = $code; +} + +=item $con->register_fallback($path, \&handler) + +Registers a handler for messages whose path starts with +the prefix 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 class). + +=cut + +sub register_fallback { + my $self = shift; + my $path = shift; + my $code = shift; + + $self->{objects}->{$path} = $code; + $self->{objectTrees}->{$path} = $code; +} + +=item $con->unregister_object_path($path) + +Unregisters the handler associated with the object path C<$path>. The +handler would previously have been registered with the C +or C methods. + +=cut + +sub unregister_object_path { + my $self = shift; + my $path = shift; + + delete $self->{objects}->{$path}; +} + +sub _call_method { + my $self = shift; + my $msg = shift; + + if (exists $self->{objects}->{$msg->get_path}) { + my $cb = $self->{objects}->{$msg->get_path}; + &$cb($self, $msg); + } else { + foreach my $path (reverse sort { $a cmp $b } keys %{$self->{objectTrees}}) { + if ((index $msg->get_path, $path) == 0) { + my $cb = $self->{objects}->{$path}; + &$cb($self, $msg); + return; + } + } + if ($msg->get_path eq "/org/freedesktop/DBus") { + if ($msg->get_member eq "GetNameOwner") { + my $reply = $self->make_method_return_message($msg); + my $iter = $reply->iterator(1); + $iter->append(":1.1"); + $self->send($reply); + } + } + } +} + +=item my $msg = $con->make_error_message($replyto, $name, $description) + +Creates a new message, representing an error which occurred during +the handling of the method call object passed in as the C<$replyto> +parameter. The C<$name> parameter is the formal name of the error +condition, while the C<$description> is a short piece of text giving +more specific information on the error. + +=cut + +sub make_error_message { + my $self = shift; + my $replyto = shift; + my $name = shift; + my $description = shift; + + if (1) { + return Net::DBus::Test::MockMessage->new_error(replyto => $replyto, + error_name => $name, + error_description => $description); + } else { + return Net::DBus::Binding::Message::Error->new(replyto => $replyto, + name => $name, + description => $description); + } +} + +=item my $call = $con->make_method_call_message( + $service_name, $object_path, $interface, $method_name); + +Create a message representing a call on the object located at +the path C<$object_path> within the client owning the well-known +name given by C<$service_name>. The method to be invoked has +the name C<$method_name> within the interface specified by the +C<$interface> parameter. + +=cut + +sub make_method_call_message { + my $self = shift; + my $service_name = shift; + my $object_path = shift; + my $interface = shift; + my $method_name = shift; + + if (1) { + return Net::DBus::Test::MockMessage->new_method_call(destination => $service_name, + path => $object_path, + interface => $interface, + member => $method_name); + } else { + return Net::DBus::Binding::Message::MethodCall->new(service_name => $service_name, + object_path => $object_path, + interface => $interface, + method_name => $method_name); + } +} + +=item my $msg = $con->make_method_return_message($replyto) + +Create a message representing a reply to the method call message passed in +the C<$replyto> parameter. + +=cut + + +sub make_method_return_message { + my $self = shift; + my $replyto = shift; + + if (1) { + return Net::DBus::Test::MockMessage->new_method_return(replyto => $replyto); + } else { + return Net::DBus::Binding::Message::MethodReturn->new(call => $replyto); + } +} + + +=item my $msg = $con->make_signal_message($object_path, $interface, $signal_name); + +Creates a new message, representing a signal [to be] emitted by +the object located under the path given by the C<$object_path> +parameter. The name of the signal is given by the C<$signal_name> +parameter, and is scoped to the interface given by the +C<$interface> parameter. + +=cut + +sub make_signal_message { + my $self = shift; + my $object_path = shift; + my $interface = shift; + my $signal_name = shift; + + if (1) { + return Net::DBus::Test::MockMessage->new_signal(object_path => $object_path, + interface => $interface, + signal_name => $signal_name); + } else { + return Net::DBus::Binding::Message::Signal->new(object_path => $object_path, + interface => $interface, + signal_name => $signal_name); + } +} + + +1; + +=pod + +=back + +=head1 BUGS + +It doesn't completely replicate the API of L, +merely enough to make the high level bindings work in a test scenario. + +=head1 AUTHOR + +Daniel P. Berrange + +=head1 COPYRIGHT + +Copyright (C) 2005-2009 Daniel P. Berrange + +=head1 SEE ALSO + +L, L, L, +L + +=cut diff --git a/lib/Net/DBus/Test/MockIterator.pm b/lib/Net/DBus/Test/MockIterator.pm new file mode 100644 index 0000000..125a879 --- /dev/null +++ b/lib/Net/DBus/Test/MockIterator.pm @@ -0,0 +1,966 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Test::MockIterator - Iterator over a mock message + +=head1 SYNOPSIS + +Creating a new message + + my $msg = new Net::DBus::Test::MockMessage + my $iterator = $msg->iterator; + + $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 + +This module provides a "mock" counterpart to the L +object which is capable of iterating over mock message objects. Instances of this +module are not created directly, instead they are obtained via the C +method on the L module. + +=head1 METHODS + +=over 4 + +=cut + +package Net::DBus::Test::MockIterator; + + +use 5.006; +use strict; +use warnings; + +sub _new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = {}; + my %params = @_; + + $self->{data} = exists $params{data} ? $params{data} : die "data parameter is required"; + $self->{append} = exists $params{append} ? $params{append} : 0; + $self->{position} = 0; + + bless $self, $class; + + return $self; +} + +=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. + +=cut + +sub has_next { + my $self = shift; + + if ($self->{position} < $#{$self->{data}}) { + return 1; + } + return 0; +} + + +=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. + +=cut + +sub next { + my $self = shift; + + $self->{position}++; + if ($self->{position} <= $#{$self->{data}}) { + return 1; + } + return 0; +} + +=item my $val = $iter->get_boolean() + +=item $iter->append_boolean($val); + +Read or write a boolean value from/to the +message iterator + +=cut + +sub get_boolean { + my $self = shift; + return $self->_get(&Net::DBus::Binding::Message::TYPE_BOOLEAN); +} + +sub append_boolean { + my $self = shift; + $self->_append(&Net::DBus::Binding::Message::TYPE_BOOLEAN, $_[0] ? 1 : ""); +} + +=item my $val = $iter->get_byte() + +=item $iter->append_byte($val); + +Read or write a single byte value from/to the +message iterator. + +=cut + +sub get_byte { + my $self = shift; + return $self->_get(&Net::DBus::Binding::Message::TYPE_BYTE); +} + +sub append_byte { + my $self = shift; + $self->_append(&Net::DBus::Binding::Message::TYPE_BYTE, $_[0]); +} + + +=item my $val = $iter->get_string() + +=item $iter->append_string($val); + +Read or write a UTF-8 string value from/to the +message iterator + + +=cut + +sub get_string { + my $self = shift; + return $self->_get(&Net::DBus::Binding::Message::TYPE_STRING); +} + +sub append_string { + my $self = shift; + $self->_append(&Net::DBus::Binding::Message::TYPE_STRING, $_[0]); +} + +=item my $val = $iter->get_object_path() + +=item $iter->append_object_path($val); + +Read or write a UTF-8 string value, whose contents is +a valid object path, from/to the message iterator + + +=cut + +sub get_object_path { + my $self = shift; + return $self->_get(&Net::DBus::Binding::Message::TYPE_OBJECT_PATH); +} + +sub append_object_path { + my $self = shift; + $self->_append(&Net::DBus::Binding::Message::TYPE_OBJECT_PATH, $_[0]); +} + +=item my $val = $iter->get_signature() + +=item $iter->append_signature($val); + +Read or write a UTF-8 string, whose contents is a +valid type signature, value from/to the message iterator + + +=cut + +sub get_signature { + my $self = shift; + return $self->_get(&Net::DBus::Binding::Message::TYPE_SIGNATURE); +} + +sub append_signature { + my $self = shift; + $self->_append(&Net::DBus::Binding::Message::TYPE_SIGNATURE, $_[0]); +} + +=item my $val = $iter->get_int16() + +=item $iter->append_int16($val); + +Read or write a signed 16 bit value from/to the +message iterator + + +=cut + +sub get_int16 { + my $self = shift; + return $self->_get(&Net::DBus::Binding::Message::TYPE_INT16); +} + +sub append_int16 { + my $self = shift; + $self->_append(&Net::DBus::Binding::Message::TYPE_INT16, int($_[0])); +} + +=item my $val = $iter->get_uint16() + +=item $iter->append_uint16($val); + +Read or write an unsigned 16 bit value from/to the +message iterator + + +=cut + +sub get_uint16 { + my $self = shift; + return $self->_get(&Net::DBus::Binding::Message::TYPE_UINT16); +} + +sub append_uint16 { + my $self = shift; + $self->_append(&Net::DBus::Binding::Message::TYPE_UINT16, int($_[0])); +} + +=item my $val = $iter->get_int32() + +=item $iter->append_int32($val); + +Read or write a signed 32 bit value from/to the +message iterator + + +=cut + +sub get_int32 { + my $self = shift; + return $self->_get(&Net::DBus::Binding::Message::TYPE_INT32); +} + +sub append_int32 { + my $self = shift; + $self->_append(&Net::DBus::Binding::Message::TYPE_INT32, int($_[0])); +} + +=item my $val = $iter->get_uint32() + +=item $iter->append_uint32($val); + +Read or write an unsigned 32 bit value from/to the +message iterator + + +=cut + +sub get_uint32 { + my $self = shift; + return $self->_get(&Net::DBus::Binding::Message::TYPE_UINT32); +} + +sub append_uint32 { + my $self = shift; + $self->_append(&Net::DBus::Binding::Message::TYPE_UINT32, int($_[0])); +} + +=item my $val = $iter->get_int64() + +=item $iter->append_int64($val); + +Read or write a signed 64 bit value from/to the +message iterator. An error will be raised if this +build of Perl does not support 64 bit integers + + +=cut + +sub get_int64 { + my $self = shift; + return $self->_get(&Net::DBus::Binding::Message::TYPE_INT64); +} + +sub append_int64 { + my $self = shift; + $self->_append(&Net::DBus::Binding::Message::TYPE_INT64, int($_[0])); +} + +=item my $val = $iter->get_uint64() + +=item $iter->append_uint64($val); + +Read or write an unsigned 64 bit value from/to the +message iterator. An error will be raised if this +build of Perl does not support 64 bit integers + + +=cut + +sub get_uint64 { + my $self = shift; + return $self->_get(&Net::DBus::Binding::Message::TYPE_UINT64); +} + +sub append_uint64 { + my $self = shift; + $self->_append(&Net::DBus::Binding::Message::TYPE_UINT64, int($_[0])); +} + +=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_double { + my $self = shift; + return $self->_get(&Net::DBus::Binding::Message::TYPE_DOUBLE); +} + +sub append_double { + my $self = shift; + $self->_append(&Net::DBus::Binding::Message::TYPE_DOUBLE, $_[0]); +} + + + +=item my $value = $iter->get() + +=item my $value = $iter->get($type); + +Get the current value pointed to by this iterator. If the optional +C<$type> parameter is supplied, the wire type will be compared with +the desired type & a warning output if their differ. The C<$type> +value must be one of the C +constants. + +=cut + +sub get { + my $self = shift; + my $type = shift; + + if (defined $type) { + if (ref($type)) { + if (ref($type) eq "ARRAY") { + # XXX we should recursively validate types + $type = $type->[0]; + if ($type eq &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { + $type = &Net::DBus::Binding::Message::TYPE_ARRAY; + } + } else { + die "unsupport type reference $type"; + } + } + + my $actual = $self->get_arg_type; + if ($actual != $type) { + # "Be strict in what you send, be leniant in what you accept" + # - ie can't rely on python to send correct types, eg int32 vs uint32 + #die "requested type '" . chr($type) . "' ($type) did not match wire type '" . chr($actual) . "' ($actual)"; + warn "requested type '" . chr($type) . "' ($type) did not match wire type '" . chr($actual) . "' ($actual)"; + $type = $actual; + } + } else { + $type = $self->get_arg_type; + } + + if ($type == &Net::DBus::Binding::Message::TYPE_STRING) { + return $self->get_string; + } elsif ($type == &Net::DBus::Binding::Message::TYPE_BOOLEAN) { + return $self->get_boolean; + } elsif ($type == &Net::DBus::Binding::Message::TYPE_BYTE) { + return $self->get_byte; + } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT16) { + return $self->get_int16; + } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT16) { + return $self->get_uint16; + } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT32) { + return $self->get_int32; + } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT32) { + return $self->get_uint32; + } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT64) { + return $self->get_int64; + } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT64) { + return $self->get_uint64; + } elsif ($type == &Net::DBus::Binding::Message::TYPE_DOUBLE) { + return $self->get_double; + } elsif ($type == &Net::DBus::Binding::Message::TYPE_ARRAY) { + my $array_type = $self->get_element_type(); + if ($array_type == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { + return $self->get_dict(); + } else { + return $self->get_array($array_type); + } + } elsif ($type == &Net::DBus::Binding::Message::TYPE_STRUCT) { + return $self->get_struct(); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_VARIANT) { + return $self->get_variant(); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { + die "dictionary can only occur as part of an array type"; + } elsif ($type == &Net::DBus::Binding::Message::TYPE_INVALID) { + die "cannot handle Net::DBus::Binding::Message::TYPE_INVALID"; + } elsif ($type == &Net::DBus::Binding::Message::TYPE_OBJECT_PATH) { + return $self->get_object_path(); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_SIGNATURE) { + return $self->get_signature(); + } else { + die "unknown argument type '" . chr($type) . "' ($type)"; + } +} + +=item my $hashref = $iter->get_dict() + +If the iterator currently points to a dictionary value, unmarshalls +and returns the value as a hash reference. + +=cut + +sub get_dict { + my $self = shift; + + my $iter = $self->_recurse(); + my $type = $iter->get_arg_type(); + my $dict = {}; + while ($type == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { + my $entry = $iter->get_struct(); + if ($#{$entry} != 1) { + die "Dictionary entries must be structs of 2 elements. This entry has " . ($#{$entry}+1) ." elements"; + } + + $dict->{$entry->[0]} = $entry->[1]; + $iter->next(); + $type = $iter->get_arg_type(); + } + return $dict; +} + +=item my $hashref = $iter->get_array() + +If the iterator currently points to an array value, unmarshalls +and returns the value as a array reference. + +=cut + +sub get_array { + my $self = shift; + my $array_type = shift; + + my $iter = $self->_recurse(); + my $type = $iter->get_arg_type(); + my $array = []; + while ($type != &Net::DBus::Binding::Message::TYPE_INVALID) { + if ($type != $array_type) { + die "Element $type not of array type $array_type"; + } + + my $value = $iter->get($type); + push @{$array}, $value; + $iter->next(); + $type = $iter->get_arg_type(); + } + return $array; +} + +=item my $hashref = $iter->get_variant() + +If the iterator currently points to a variant value, unmarshalls +and returns the value contained in the variant. + +=cut + +sub get_variant { + my $self = shift; + + my $iter = $self->_recurse(); + return $iter->get(); +} + + +=item my $hashref = $iter->get_struct() + +If the iterator currently points to an struct value, unmarshalls +and returns the value as a array reference. The values in the array +correspond to members of the struct. + +=cut + +sub get_struct { + my $self = shift; + + my $iter = $self->_recurse(); + my $type = $iter->get_arg_type(); + my $struct = []; + while ($type != &Net::DBus::Binding::Message::TYPE_INVALID) { + my $value = $iter->get($type); + push @{$struct}, $value; + $iter->next(); + $type = $iter->get_arg_type(); + } + return $struct; +} + +=item $iter->append($value) + +=item $iter->append($value, $type) + +Appends a value to the message associated with this iterator. The +value is marshalled into wire format, according to the following +rules. + +If the C<$value> is an instance of L, +the embedded data type is used. + +If the C<$type> parameter is supplied, that is taken to represent +the data type. The type must be one of the C +constants. + +Otherwise, the data type is chosen to be a string, dict or array +according to the perl data types SCALAR, HASH or ARRAY. + +=cut + +sub append { + my $self = shift; + my $value = shift; + my $type = shift; + + if (ref($value) eq "Net::DBus::Binding::Value" && + ((! defined ref($type)) || + (ref($type) ne "ARRAY") || + $type->[0] != &Net::DBus::Binding::Message::TYPE_VARIANT)) { + $type = $value->type; + $value = $value->value; + } + + if (!defined $type) { + $type = $self->guess_type($value); + } + + if (ref($type) eq "ARRAY") { + my $maintype = $type->[0]; + my $subtype = $type->[1]; + + if ($maintype == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { + $self->append_dict($value, $subtype); + } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_STRUCT) { + $self->append_struct($value, $subtype); + } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_ARRAY) { + $self->append_array($value, $subtype); + } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_VARIANT) { + $self->append_variant($value, $subtype); + } else { + die "Unsupported compound type ", $maintype, " ('", chr($maintype), "')"; + } + } else { + # XXX is this good idea or not + $value = '' unless defined $value; + + if ($type == &Net::DBus::Binding::Message::TYPE_BOOLEAN) { + $self->append_boolean($value); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_BYTE) { + $self->append_byte($value); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_STRING) { + $self->append_string($value); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT16) { + $self->append_int16($value); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT16) { + $self->append_uint16($value); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT32) { + $self->append_int32($value); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT32) { + $self->append_uint32($value); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_INT64) { + $self->append_int64($value); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_UINT64) { + $self->append_uint64($value); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_DOUBLE) { + $self->append_double($value); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_OBJECT_PATH) { + $self->append_object_path($value); + } elsif ($type == &Net::DBus::Binding::Message::TYPE_SIGNATURE) { + $self->append_signature($value); + } else { + die "Unsupported scalar type ", $type, " ('", chr($type), "')"; + } + } +} + + +=item my $type = $iter->guess_type($value) + +Make a best guess at the on the wire data type to use for +marshalling C<$value>. If the value is a hash reference, +the dictionary type is returned; if the value is an array +reference the array type is returned; otherwise the string +type is returned. + +=cut + +sub guess_type { + my $self = shift; + my $value = shift; + + if (ref($value)) { + if (UNIVERSAL::isa($value, "Net::DBus::Binding::Value")) { + my $type = $value->type; + if (ref($type) && ref($type) eq "ARRAY") { + my $maintype = $type->[0]; + my $subtype = $type->[1]; + + if (!defined $subtype) { + if ($maintype == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { + $subtype = [ $self->guess_type(($value->value())[0]->[0]), + $self->guess_type(($value->value())[0]->[1]) ]; + } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_ARRAY) { + $subtype = [ $self->guess_type(($value->value())[0]->[0]) ]; + } elsif ($maintype == &Net::DBus::Binding::Message::TYPE_STRUCT) { + $subtype = [ map { $self->guess_type($_) } @{($value->value())[0]} ]; + } else { + die "Unguessable compound type '$maintype' ('", chr($maintype), "')\n"; + } + } + return [$maintype, $subtype]; + } else { + return $type; + } + } elsif (ref($value) eq "HASH") { + my $key = (keys %{$value})[0]; + my $val = $value->{$key}; + # XXX Basically impossible to decide between DICT & STRUCT + return [ &Net::DBus::Binding::Message::TYPE_DICT_ENTRY, + [ &Net::DBus::Binding::Message::TYPE_STRING, $self->guess_type($val)] ]; + } elsif (ref($value) eq "ARRAY") { + return [ &Net::DBus::Binding::Message::TYPE_ARRAY, + [$self->guess_type($value->[0])] ]; + } else { + die "cannot marshall reference of type " . ref($value); + } + } else { + # XXX Should we bother trying to guess integer & floating point types ? + # I say sod it, because strongly typed languages will support introspection + # and loosely typed languages won't care about the difference + return &Net::DBus::Binding::Message::TYPE_STRING; + } +} + +=item my $sig = $iter->format_signature($type) + +Given a data type representation, construct a corresponding +signature string + +=cut + +sub format_signature { + my $self = shift; + my $type = shift; + my ($sig, $t, $i); + + $sig = ""; + $i = 0; + + if (ref($type) eq "ARRAY") { + while ($i <= $#{$type}) { + $t = $$type[$i]; + + if (ref($t) eq "ARRAY") { + $sig .= $self->format_signature($t); + } elsif ($t == &Net::DBus::Binding::Message::TYPE_DICT_ENTRY) { + $sig .= chr (&Net::DBus::Binding::Message::TYPE_ARRAY); + $sig .= "{" . $self->format_signature($$type[++$i]) . "}"; + } elsif ($t == &Net::DBus::Binding::Message::TYPE_STRUCT) { + $sig .= "(" . $self->format_signature($$type[++$i]) . ")"; + } else { + $sig .= chr($t); + } + + $i++; + } + } else { + $sig .= chr ($type); + } + + return $sig; +} + +=item $iter->append_array($value, $type) + +Append an array of values to the message. The C<$value> parameter +must be an array reference, whose elements all have the same data +type specified by the C<$type> parameter. + +=cut + +sub append_array { + my $self = shift; + my $array = shift; + my $type = shift; + + if (!defined($type)) { + $type = [$self->guess_type($array->[0])]; + } + + die "array must only have one type" + if $#{$type} > 0; + + my $sig = $self->format_signature($type); + my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_ARRAY, $sig); + + foreach my $value (@{$array}) { + $iter->append($value, $type->[0]); + } +} + + +=item $iter->append_struct($value, $type) + +Append a struct to the message. The C<$value> parameter +must be an array reference, whose elements correspond to +members of the structure. The C<$type> parameter encodes +the type of each member of the struct. + +=cut + +sub append_struct { + my $self = shift; + my $struct = shift; + my $type = shift; + + if (defined($type) && + $#{$struct} != $#{$type}) { + die "number of values does not match type"; + } + + my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_STRUCT, ""); + + my @type = defined $type ? @{$type} : (); + foreach my $value (@{$struct}) { + $iter->append($value, shift @type); + } +} + +=item $iter->append_dict($value, $type) + +Append a dictionary to the message. The C<$value> parameter +must be an hash reference.The C<$type> parameter encodes +the type of the key and value of the hash. + +=cut + +sub append_dict { + my $self = shift; + my $hash = shift; + my $type = shift; + + my $sig; + + $sig = "{"; + $sig .= $self->format_signature($type); + $sig .= "}"; + + my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_ARRAY, $sig); + + foreach my $key (keys %{$hash}) { + my $value = $hash->{$key}; + my $entry = $iter->_open_container(&Net::DBus::Binding::Message::TYPE_DICT_ENTRY, $sig); + + $entry->append($key, $type->[0]); + $entry->append($value, $type->[1]); + } +} + +=item $iter->append_variant($value) + +Append a value to the message, encoded as a variant type. The +C<$value> can be of any type, however, the variant will be +encoded as either a string, dictionary or array according to +the rules of the C method. + +=cut + +sub append_variant { + my $self = shift; + my $value = shift; + my $type = shift; + + if (UNIVERSAL::isa($value, "Net::DBus::Binding::Value")) { + $type = [$self->guess_type($value)]; + $value = $value->value; + } elsif (!defined $type || !defined $type->[0]) { + $type = [$self->guess_type($value)]; + } + die "variant must only have one type" + if defined $type && $#{$type} > 0; + + my $sig = $self->format_signature($type->[0]); + my $iter = $self->_open_container(&Net::DBus::Binding::Message::TYPE_VARIANT, $sig); + $iter->append($value, $type->[0]); +} + + +=item my $type = $iter->get_arg_type + +Retrieves the type code of the value pointing to by this iterator. +The returned code will correspond to one of the constants +C + +=cut + +sub get_arg_type { + my $self = shift; + + return &Net::DBus::Binding::Message::TYPE_INVALID + if $self->{position} > $#{$self->{data}}; + + my $data = $self->{data}->[$self->{position}]; + return $data->[0]; +} + +=item my $type = $iter->get_element_type + +If the iterator points to an array, retrieves the type code of +array elements. The returned code will correspond to one of the +constants C + +=cut + +sub get_element_type { + my $self = shift; + + die "current element is not valid" if $self->{position} > $#{$self->{data}}; + + my $data = $self->{data}->[$self->{position}]; + if ($data->[0] != &Net::DBus::Binding::Message::TYPE_ARRAY) { + die "current element is not an array"; + } + return $data->[1]->[0]->[0]; +} + + + +sub _recurse { + my $self = shift; + + die "_recurse call is not valid for writable iterator" if $self->{append}; + + die "current element is not valid" if $self->{position} > $#{$self->{data}}; + + my $data = $self->{data}->[$self->{position}]; + + my $type = $data->[0]; + if ($type != &Net::DBus::Binding::Message::TYPE_STRUCT && + $type != &Net::DBus::Binding::Message::TYPE_ARRAY && + $type != &Net::DBus::Binding::Message::TYPE_DICT_ENTRY && + $type != &Net::DBus::Binding::Message::TYPE_VARIANT) { + die "current data element '$type' is not a container"; + } + + return $self->_new(data => $data->[1], + append => 0); +} + + +sub _append { + my $self = shift; + my $type = shift; + my $data = shift; + + die "iterator is not open for append" unless $self->{append}; + + push @{$self->{data}}, [$type, $data]; +} + + +sub _open_container { + my $self = shift; + my $type = shift; + my $sig = shift; + + my $data = []; + + push @{$self->{data}}, [$type, $data, $sig]; + + return $self->_new(data => $data, + append => 1); +} + + + +sub _get { + my $self = shift; + my $type = shift; + + die "iterator is not open for reading" if $self->{append}; + + die "current element is not valid" if $self->{position} > $#{$self->{data}}; + + my $data = $self->{data}->[$self->{position}]; + + die "data type does not match" unless $data->[0] == $type; + + return $data->[1]; +} + +1; + +=pod + +=back + +=head1 BUGS + +It doesn't completely replicate the API of L, +merely enough to make the high level bindings work in a test scenario. + +=head1 AUTHOR + +Daniel P. Berrange + +=head1 COPYRIGHT + +Copyright (C) 2005-2009 Daniel P. Berrange + +=head1 SEE ALSO + +L, L, +L + +=cut diff --git a/lib/Net/DBus/Test/MockMessage.pm b/lib/Net/DBus/Test/MockMessage.pm new file mode 100644 index 0000000..ee78558 --- /dev/null +++ b/lib/Net/DBus/Test/MockMessage.pm @@ -0,0 +1,445 @@ +# -*- perl -*- +# +# Copyright (C) 2005-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Test::MockMessage - Fake a message object when unit testing + +=head1 SYNOPSIS + +Sending a message + + my $msg = new Net::DBus::Test::MockMessage; + my $iterator = $msg->iterator; + + $iterator->append_byte(132); + $iterator->append_int32(14241); + + $connection->send($msg); + +=head1 DESCRIPTION + +This module provides a "mock" counterpart to the L +class. It is basically a pure Perl fake message object providing the same +contract as the real message object. It is intended for use internally by the +testing APIs. + +=head1 METHODS + +=over 4 + +=cut + +package Net::DBus::Test::MockMessage; + +use 5.006; +use strict; +use warnings; + +use vars qw($SERIAL); + +BEGIN { + $SERIAL = 1; +} + +use Net::DBus::Binding::Message; +use Net::DBus::Test::MockIterator; + +=item my $call = Net::DBus::Test::MockMessage->new_method_call( + service_name => $service, object_path => $object, + interface => $interface, method_name => $name); + +Create a message representing a call on the object located at +the path C within the client owning the well-known +name given by C. The method to be invoked has +the name C within the interface specified by the +C parameter. + +=cut + +sub new_method_call { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->_new(type => &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_CALL, @_); + + bless $self, $class; + + return $self; +} + +=item my $msg = Net::DBus::Test::MockMessage->new_method_return( + replyto => $method_call); + +Create a message representing a reply to the method call passed in +the C parameter. + +=cut + +sub new_method_return { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->_new(type => &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN, @_); + + bless $self, $class; + + return $self; +} + +=item my $signal = Net::DBus::Test::MockMessage->new_signal( + object_path => $path, interface => $interface, signal_name => $name); + +Creates a new message, representing a signal [to be] emitted by +the object located under the path given by the C +parameter. The name of the signal is given by the C +parameter, and is scoped to the interface given by the +C parameter. + +=cut + +sub new_signal { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->_new(type => &Net::DBus::Binding::Message::MESSAGE_TYPE_SIGNAL, @_); + + bless $self, $class; + + return $self; +} + +=item my $msg = Net::DBus::Test::MockMessage->new_error( + replyto => $method_call, name => $name, description => $description); + +Creates a new message, representing an error which occurred during +the handling of the method call object passed in as the C +parameter. The C parameter is the formal name of the error +condition, while the C is a short piece of text giving +more specific information on the error. + +=cut + +sub new_error { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->_new(type => &Net::DBus::Binding::Message::MESSAGE_TYPE_ERROR, @_); + + bless $self, $class; + + return $self; +} + +sub _new { + my $proto = shift; + my $class = ref($proto) || $proto; + my %params = @_; + my $self = {}; + + $self->{type} = exists $params{type} ? $params{type} : die "type parameter is required"; + $self->{interface} = exists $params{interface} ? $params{interface} : undef; + $self->{path} = exists $params{path} ? $params{path} : undef; + $self->{destination} = exists $params{destination} ? $params{destination} : undef; + $self->{sender} = exists $params{sender} ? $params{sender} : undef; + $self->{member} = exists $params{member} ? $params{member} : undef; + $self->{error_name} = exists $params{error_name} ? $params{error_name} : undef; + $self->{data} = []; + $self->{no_reply} = 0; + $self->{serial} = $SERIAL++; + $self->{replyserial} = exists $params{replyto} ? $params{replyto}->get_serial : 0; + + bless $self, $class; + + if ($self->{type} == &Net::DBus::Binding::Message::MESSAGE_TYPE_ERROR) { + my $desc = exists $params{error_description} ? $params{error_description} : ""; + my $iter = $self->iterator(1); + $iter->append_string($desc); + } + + return $self; +} + + +=item my $type = $msg->get_type + +Retrieves the type code for this message. The returned value corresponds +to one of the four C constants. + +=cut + +sub get_type { + my $self = shift; + + return $self->{type}; +} + +=item my $name = $msg->get_error_name + +Returns the formal name of the error, as previously passed in via +the C parameter in the constructor. + +=cut + +sub get_error_name { + my $self = shift; + return $self->{error_name}; +} + +=item my $interface = $msg->get_interface + +Retrieves the name of the interface targetted by this message, possibly +an empty string if there is no applicable interface for this message. + +=cut + +sub get_interface { + my $self = shift; + + return $self->{interface}; +} + +=item my $path = $msg->get_path + +Retrieves the object path associated with the message, possibly an +empty string if there is no applicable object for this message. + +=cut + +sub get_path { + my $self = shift; + + return $self->{path}; +} + +=item my $name = $msg->get_destination + +Retrieves the uniqe or well-known bus name for client intended to be +the recipient of the message. Possibly returns an empty string if +the message is being broadcast to all clients. + +=cut + +sub get_destination { + my $self = shift; + + return $self->{destination}; +} + +=item my $name = $msg->get_sender + +Retireves the unique name of the client sending the message + +=cut + +sub get_sender { + my $self = shift; + + return $self->{sender}; +} + +=item my $serial = $msg->get_serial + +Retrieves the unique serial number of this message. The number +is guarenteed unique for as long as the connection over which +the message was sent remains open. May return zero, if the message +is yet to be sent. + +=cut + +sub get_serial { + my $self = shift; + + return $self->{serial}; +} + +=item my $name = $msg->get_member + +For method calls, retrieves the name of the method to be invoked, +while for signals, retrieves the name of the signal. + +=cut + +sub get_member { + my $self = shift; + + return $self->{member}; +} + + +=item $msg->set_sender($name) + +Set the name of the client sending the message. The name must +be the unique name of the client. + +=cut + +sub set_sender { + my $self = shift; + + $self->{sender} = shift; +} + +=item $msg->set_destination($name) + +Set the name of the intended recipient of the message. This is +typically used for signals to switch them from broadcast to +unicast. + +=cut + +sub set_destination { + my $self = shift; + $self->{destination} = shift; +} + +=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 class. + +=cut + +sub iterator { + my $self = shift; + my $append = @_ ? shift : 0; + + return Net::DBus::Test::MockIterator->_new(data => $self->{data}, + append => $append); +} + +=item $boolean = $msg->get_no_reply() + +Gets the flag indicating whether the message is expecting +a reply to be sent. + +=cut + +sub get_no_reply { + my $self = shift; + + return $self->{no_reply}; +} + +=item $msg->set_no_reply($boolean) + +Toggles the flag indicating whether the message is expecting +a reply to be sent. All method call messages expect a reply +by default. By toggling this flag the communication latency +is reduced by removing the need for the client to wait + +=cut + + +sub set_no_reply { + my $self = shift; + + $self->{no_reply} = shift; +} + +=item my @values = $msg->get_args_list + +De-marshall all the values in the body of the message, using the +message signature to identify data types. The values are returned +as a list. + +=cut + +sub get_args_list { + my $self = shift; + + my @ret; + my $iter = $self->iterator; + if ($iter->get_arg_type() != &Net::DBus::Binding::Message::TYPE_INVALID) { + do { + push @ret, $iter->get(); + } while ($iter->next); + } + + return @ret; +} + +=item $msg->append_args_list(@values) + +Append a set of values to the body of the message. Values will +be encoded as either a string, list or dictionary as appropriate +to their Perl data type. For more specific data typing needs, +the L object should be used instead. + +=cut + +sub append_args_list { + my $self = shift; + my @args = @_; + + my $iter = $self->iterator(1); + foreach my $arg (@args) { + $iter->append($arg); + } +} + +=item my $sig = $msg->get_signature + +Retrieves a string representing the type signature of the values +packed into the body of the message. + +=cut + + +sub get_signature { + my $self = shift; + + my @bits = map { $self->_do_get_signature($_) } @{$self->{data}}; + return join ("", @bits); +} + +sub _do_get_signature { + my $self = shift; + my $element = shift; + + if ($element->[0] == &Net::DBus::Binding::Message::TYPE_ARRAY) { + return chr(&Net::DBus::Binding::Message::TYPE_ARRAY) . $element->[2]; + } elsif ($element->[0] == &Net::DBus::Binding::Message::TYPE_STRUCT) { + my @bits = map { $self->_do_get_signature($_) } @{$element->[1]}; + return "{" . join("", @bits) . "}"; + } elsif ($element->[0] == &Net::DBus::Binding::Message::TYPE_VARIANT) { + return chr(&Net::DBus::Binding::Message::TYPE_VARIANT); + } else { + return chr($element->[0]); + } +} + +1; + +=pod + +=back + + +=head1 AUTHOR + +Daniel P. Berrange + +=head1 COPYRIGHT + +Copyright (C) 2005-2009 Daniel P. Berrange + +=head1 SEE ALSO + +L, L, L + +=cut diff --git a/lib/Net/DBus/Test/MockObject.pm b/lib/Net/DBus/Test/MockObject.pm new file mode 100644 index 0000000..2308372 --- /dev/null +++ b/lib/Net/DBus/Test/MockObject.pm @@ -0,0 +1,322 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2011 Daniel P. Berrange +# +# This program is free software; You can redistribute it and/or modify +# it under the same terms as Perl itself. Either: +# +# a) the GNU General Public License as published by the Free +# Software Foundation; either version 2, or (at your option) any +# later version, +# +# or +# +# b) the "Artistic License" +# +# The file "COPYING" distributed along with this file provides full +# details of the terms and conditions of the two licenses. + +=pod + +=head1 NAME + +Net::DBus::Test::MockObject - Fake an object from the bus for unit testing + +=head1 SYNOPSIS + + use Net::DBus; + use Net::DBus::Test::MockObject; + + my $bus = Net::DBus->test + + # Lets fake presence of HAL... + + # First we need to define the service + my $service = $bus->export_service("org.freedesktop.Hal"); + + # Then create a mock object + my $object = Net::DBus::Test::MockObject->new($service, + "/org/freedesktop/Hal/Manager"); + + # Fake the 'GetAllDevices' method + $object->seed_action("org.freedesktop.Hal.Manager", + "GetAllDevices", + reply => { + return => [ "/org/freedesktop/Hal/devices/computer_i8042_Aux_Port", + "/org/freedesktop/Hal/devices/computer_i8042_Aux_Port_logicaldev_input", + "/org/freedesktop/Hal/devices/computer_i8042_Kbd_Port", + "/org/freedesktop/Hal/devices/computer_i8042_Kbd_Port_logicaldev_input" + ], + }); + + + # Now can test any class which calls out to 'GetAllDevices' in HAL + ....test stuff.... + +=head1 DESCRIPTION + +This provides an alternate for L to enable bus +objects to be quickly mocked up, thus facilitating creation of unit +tests for services which may need to call out to objects provided +by 3rd party services on the bus. It is typically used as a companion +to the L object, to enable complex services to +be tested without actually starting a real bus. + +!!!!! WARNING !!! + +This object & its APIs should be considered very experimental at +this point in time, and no guarentees about future API compatability +are provided what-so-ever. Comments & suggestions on how to evolve +this framework are, however, welcome & encouraged. + +=head1 METHODS + +=over 4 + +=cut + +package Net::DBus::Test::MockObject; + +use strict; +use warnings; + +=item my $object = Net::DBus::Test::MockObject->new($service, $path, $interface); + +Create a new mock object, attaching to the service defined by the C<$service> +parameter. This would be an instance of the L object. The +C<$path> parameter defines the object path at which to attach this mock object, +and C<$interface> defines the interface it will support. + +=cut + +sub new { + my $class = shift; + my $self = {}; + + $self->{service} = shift; + $self->{object_path} = shift; + $self->{interface} = shift; + $self->{actions} = {}; + $self->{message} = shift; + + bless $self, $class; + + $self->get_service->_register_object($self); + + return $self; +} + + +sub _get_sub_nodes { + my $self = shift; + return []; +} + +=item my $service = $object->get_service + +Retrieves the L object within which this +object is exported. + +=cut + +sub get_service { + my $self = shift; + return $self->{service}; +} + +=item my $path = $object->get_object_path + +Retrieves the path under which this object is exported + +=cut + +sub get_object_path { + my $self = shift; + return $self->{object_path}; +} + + +=item my $msg = $object->get_last_message + +Retrieves the last message processed by this object. The returned +object is an instance of L + +=cut + +sub get_last_message { + my $self = shift; + return $self->{message}; +} + +=item my $sig = $object->get_last_message_signature + +Retrieves the type signature of the last processed message. + +=cut + +sub get_last_message_signature { + my $self = shift; + return $self->{message}->get_signature; +} + +=item my $value = $object->get_last_message_param + +Returns the first value supplied as an argument to the last +processed message. + +=cut + +sub get_last_message_param { + my $self = shift; + my @args = $self->{message}->get_args_list; + return $args[0]; +} + +=item my @values = $object->get_last_message_param_list + +Returns a list of all the values supplied as arguments to +the last processed message. + +=cut + +sub get_last_message_param_list { + my $self = shift; + my @args = $self->{message}->get_args_list; + return \@args; +} + +=item $object->seed_action($interface, $method, %action); + +Registers an action to be performed when a message corresponding +to the method C<$method> within the interface C<$interface> is +received. The C<%action> parameter can have a number of possible +keys set: + +=over 4 + +=item signals + +Causes a signal to be emitted when the method is invoked. The +value associated with this key should be an instance of the +L class. + +=item error + +Causes an error to be generated when the method is invoked. The +value associated with this key should be a hash reference, with +two elements. The first, C, giving the error name, and the +second, C, providing the descriptive text. + +=item reply + +Causes a normal method return to be generated. The value associated +with this key should be an array reference, whose elements are the +values to be returned by the method. + +=back + +=cut + +sub seed_action { + my $self = shift; + my $interface = shift; + my $method = shift; + my %action = @_; + + $self->{actions}->{$method} = {} unless exists $self->{actions}->{$method}; + $self->{actions}->{$method}->{$interface} = \%action; +} + +sub _dispatch { + my $self = shift; + my $connection = shift; + my $message = shift; + + my $interface = $message->get_interface; + my $method = $message->get_member; + + my $con = $self->get_service->get_bus->get_connection; + + if (!exists $self->{actions}->{$method}) { + my $error = $con->make_error_message($message, + "org.freedesktop.DBus.Failed", + "no action seeded for method " . $message->get_member); + $con->send($error); + return; + } + + my $action; + if ($interface) { + if (!exists $self->{actions}->{$method}->{$interface}) { + my $error = $con->make_error_message($message, + "org.freedesktop.DBus.Failed", + "no action with correct interface seeded for method " . $message->get_member); + $con->send($error); + return; + } + $action = $self->{actions}->{$method}->{$interface}; + } else { + my @interfaces = keys %{$self->{actions}->{$method}}; + if ($#interfaces > 0) { + my $error = $con->make_error_message($message, + "org.freedesktop.DBus.Failed", + "too many actions seeded for method " . $message->get_member); + $con->send($error); + return; + } + $action = $self->{actions}->{$method}->{$interfaces[0]}; + } + + if (exists $action->{signals}) { + my $sigs = $action->{signals}; + if (ref($sigs) ne "ARRAY") { + $sigs = [ $sigs ]; + } + foreach my $sig (@{$sigs}) { + $self->get_service->get_bus->get_connection->send($sig); + } + } + + $self->{message} = $message; + + if (exists $action->{error}) { + my $error = $con->make_error_message($message, + $action->{error}->{name}, + $action->{error}->{description}); + $con->send($error); + } elsif (exists $action->{reply}) { + my $reply = $con->make_method_return_message($message); + my $iter = $reply->iterator(1); + foreach my $value (@{$action->{reply}->{return}}) { + $iter->append($value); + } + $con->send($reply); + } +} + + +1; + +=pod + +=back + +=head1 BUGS + +It doesn't completely replicate the API of L, +merely enough to make the high level bindings work in a test scenario. + +=head1 AUTHOR + +Daniel P. Berrange + +=head1 COPYRIGHT + +Copyright (C) 2004-2009 Daniel P. Berrange + +=head1 SEE ALSO + +L, L, L, +L + +=cut diff --git a/lib/Net/DBus/Tutorial.pod b/lib/Net/DBus/Tutorial.pod new file mode 100644 index 0000000..5d9846b --- /dev/null +++ b/lib/Net/DBus/Tutorial.pod @@ -0,0 +1,66 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2005 Daniel P. Berrange +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# $Id: Tutorial.pod,v 1.2 2006/02/03 13:34:18 dan Exp $ + +=pod + +=head1 NAME + +Net::DBus::Tutorial - tutorials on the Perl DBus APIs + +=head1 DESCRIPTION + +This section includes tutorials on the Perl DBus APIs. Current +topics include providing a service, by exporting objects to the +bus, and accessing a service, by calling objects on the bus. + +=over 4 + +=item L + +This tutorial covers how to provide a service to the bus by +exporting objects. The topics covered include basics of creating +objects and methods, emitting signals, exporting properties, +registering services for automatic activation. + +=item L + +This tutorial cover how to use a service provided on the bus +by another application. The topics covered include the basics +of calling methods on remote objects, explicitly calling methods +in particular interfaces, listening for signals. + +NB This tutorial is yet to be written. + +=back + +=head1 SEE ALSO + +L, L, L, +L + +=head1 AUTHORS + +Daniel P. Berrange L + +=head1 COPYRIGHT + +Copyright 2005 Daniel P. Berrange + +=cut diff --git a/lib/Net/DBus/Tutorial/ExportingObjects.pod b/lib/Net/DBus/Tutorial/ExportingObjects.pod new file mode 100644 index 0000000..a95b073 --- /dev/null +++ b/lib/Net/DBus/Tutorial/ExportingObjects.pod @@ -0,0 +1,329 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2005 Daniel P. Berrange +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# $Id: ExportingObjects.pod,v 1.1 2006/01/27 14:02:35 dan Exp $ + +=pod + +=head1 NAME + +Net::DBus::Tutorial::ExportingObjects - tutorials on providing a DBus service + +=head1 DESCRIPTION + +This document provides a tutorial on providing a DBus service using the +Perl Net::DBus application bindings. This examples in this document +will be based on the code from the L distribution, which +is a simple DBus service providing a music track player. + +=head1 CREATING AN OBJECT + +The first step in creating an object is to create a new package +which inherits from L. The Music::Player::Manager +object provides an API for managing the collection of music player +backends for different track types. To start with, lets create the +skeleton of the package & its constructor. The constructor of the +super type, L expects to be given to parameters, +a handle to the L owning the object, and a path +under which the object shall be exported. Since the manager class is +intended to be a singleton object, we can hard code the path to it +within the constructor: + + package Music::Player::Manager; + + use base qw(Net::DBus); + + sub new { + my $class = shift; + my $service = shift; + my $self = $class->SUPER::new($service, "/music/player/manager"); + + bless $self, $class; + + return $self; + } + + 1; + + +Now, as mentioned, the manager with handle a number of different +player backends. So we need to provide methods for registering +new backends, and querying for backends capable of playing a +particular file type. So modifying the above code we add a hash +table in the constructor, to store the backends: + + + sub new { + my $class = shift; + my $service = shift; + my $self = $class->SUPER::new($service, "/music/player/manager"); + + $self->{backends} = {}; + + bless $self, $class; + + return $self; + } + +And now a method to register a new backend. This takes a Perl +module name and uses it to instantiate a backend. Since the +backends are also going to be DBus objects, we need to pass +in a reference to the service we are attached to, along with +a path under which to register the backend. We use the C +method to retreieve a reference to the service the manager is +attached to, and attach the player backend to this same service: +When a method on DBus object is invoked, the first parameter is +the object reference (C<$self>), and the remainder are the +parameters provided to the method call. Thus writing a method +implementation on a DBUs is really no different to normal object +oriented Perl (cf L): + + sub register_backend { + my $self = shift; + my $name = shift; + my $module = shift; + + eval "use $module"; + if ($@) { + die "cannot load backend $module: $@" ; + } + + $self->{backends} = $module->new($self->get_service, + "/music/player/backend/$name"); + } + +Looking at this one might wonder what happens if the C +method is triggered. In such a scenario, rather than terminating +the service process, the error will be caught and propagated back +to the remote caller to deal with. + +The player backends provide a method C which returns +an array reference of the music track types they support. We can use +this method to provide an API to allow easy retrieval of a backend +for a particular track type. This method will return a path with which +the backend object can be accessed + + sub find_backend { + my $self = shift; + my $extension = shift; + + foreach my $name (keys %{$self->{backends}}) { + my $backend = $self->{backends}->{$name}; + foreach my $type (@{$backend->get_track_types}) { + if ($type eq $extension) { + return $backend->get_object_path; + } + } + } + + die "no backend for type $extension"; + } + +Lets take a quick moment to consider how this method would be used to +play a music track. If you've not already done so, refresh your memory +from L. Now, we have an MP3 file +which we wish to play, so we search for the path to a backend, then +retrieve the object for it, and play the track: + + ...get the music player service... + # Ask for a path to a player for mp3 files + my $path = $service->find_backend("mp3"); + # $path now contains '/music/player/backend/mpg123' + # and we can get the backend object + my $backend = $service->get_object($path); + # and finally play the track + $backend->play("/vol/music/beck/guero/09-scarecrow.mp3"); + +=head1 PROVIDING INTROSPECTION DATA + +The code above is a complete working object, ready to be registered with +a service, and since the parameters and return values for the two methods +are both simple strings we could stop there. In some cases, however, one +might want to be more specific about data types expected for parameters, +for example signed vs unsigned integers. Adding explicit data typing also +makes interaction with other programming languages more reliable. Providing +explicit data type defintions for exported method is known in the DBus world +as C, and it makes life much more reliable for users of one's +service whom may be using a strongly typed language such as C. + +The first step in providing introspection data for a DBus object in Perl, is +to specify the name of the interface provided by the object. This is typically +a period separated string, by convention containing the domain name of the +application as its first component. Since most Perl modules end up living on +CPAN, one might use C as the first component, followed by the package +name of the module (replacing :: with .), eg C. If it is +not planned to host the module on CPAN, a personal/project domain might be +used eg C. The interface for an object is defined +by loading the L module, providing the interface as its +first parameter. So the earlier code example would be modified to look like: + + package Music::Player::Manager; + + use base qw(Net::DBus); + use Net::DBus::Exporter qw(com.berrange.music.player.manager) + +Next up, it is neccessary to provide data types for the parameters and return +values of the methods. The L module provides a method +C for this purpose, which takes three parameter, the name of the +method being exported, an array reference of parameter types, and an array +reference of return types (the latter can be omitted if there are no return +values). This can be called at any point in the module's code, but by convention +it is preferrable to associate calls to C with the actual method +implementation, thus: + + dbus_method("register_backend", ["string", "string"]); + sub register_backend { + my $self = shift; + my $name = shift; + my $module = shift; + + .. snipped rest of method body ... + } + +And, thus: + + dbus_method("find_backend", ["string"], ["string"]) + sub find_backend { + my $self = shift; + my $extension = shift; + ... snip method body... + } + + +=head1 DEFINING A SERVICE + +Now that the objects have been written, it is time to define +a service. A service is nothing more than a well known name +for a given API contract. A contract can be thought of as a +definition of a list of object paths, and the corresponding +interfaces they provide. So, someone else could come along a +provide an alternate music player implementation using the +Python or QT bindings for DBus, and if they provided the same +set of object paths & interfaces, they could justifiably register +the same service on the bus. + +The L module provides the means to register +a service. Its constructor expects a reference to the bus object +(an instance of L), along with the name of the service. +As with interface names, the first component of a service name is +usually derived from a domain name, and then suffixed with the +name of the application, in our example forming C. +While some objects will be created on the fly during execution +of the application, others are created upon initial startup. The +music player manager object created earlier in this tutorial is +an example of the latter. It is typical to instantiate and register +these objects in the constructor for the service. Thus a service +object for the music player application would look like: + + package Music::Player; + + use base qw(Net::DBus::Service); + + sub new { + my $class = shift; + my $bus = shift; + my $self = $class->SUPER::new($bus, "org.cpan.music.player"); + + bless $self, $class; + + $self->{manager} = Music::Player::Manager->new($self); + + return $self; + } + +The L automatically provides one special +object to all services, under the path C. +This object implements the C interface +which has a method C. This enables clients to determine +a list of all objects exported within a service. While not functionally +neccessary for most applications, it is none-the-less a useful tool for +developers debugging applications, or wondering what a service provides. + +=head1 CONNECTING TO THE BUS + +The final step in getting our service up and running is to connect it +to the bus. This brings up an interesting conundrum, does one export +the service on the system bus (shared by all users & processes on the +machine), or the session bus (one per user logged into a machine). In +some cases the answer, with only one of the two buses conceptually making +sense. In other cases, however, both the session & system bus are valid. +In the former one would use the C or methods on L +to get a handle to the desired bus, while in the latter case, the C +method would be used. This applies a heuristic to determine the correct +bus based on execution environment. In the case of the music player, either +bus is relevant, so the code to connect the service to the bus would look +like: + + use Net::DBus; + + my $bus = Net::DBus->find; + my $player = Music::Player->new($bus); + +With the service attached to the bus, it is merely neccessary to run +the main event processing loop to listen out for & handle incoming +DBus messages. So the above code is modified to start a simple reactor: + + use Net::DBus; + use Net::DBus::Reactor; + + my $bus = Net::DBus->find; + my $player = Music::Player->new($bus); + + Net::DBus::Reactor->main->run; + + exit 0; + +Saving this code into a script C, coding +is complete and the service ready for use by clients on the bus. + +=head1 SERVICE ACTIVATION + +One might now wonder how best to start the service, particularly +if it is a service capable of running on +both the system and session buses. DBus has the answer in the +concept of C. What happens is that when a client +on the bus attempts to call a method, or register a signal +handler against, a service not currently running, it will first +try and start the service. Service's which wish to participate +in this process merely need stick a simple service definition +file into the directoy C. The file +should be named to match the service name, with the file extension +C<.service> appended. eg, C +The file contains two keys, first the name of the service, and +second the name of the executable used to run the service, or in +this case the Perl script. So, for our simple service the data +file would contain: + + [D-BUS Service] + Name=org.cpan.music.player + Exec=/usr/bin/music-player.pl + +=head1 SEE ALSO + +L for details of other tutorials, and +L for API documentation + +=head1 AUTHORS + +Daniel Berrange + +=head1 COPYRIGHT + +Copyright (C) 2005 Daniel P. Berrange + +=cut diff --git a/lib/Net/DBus/Tutorial/UsingObjects.pod b/lib/Net/DBus/Tutorial/UsingObjects.pod new file mode 100644 index 0000000..3921a7f --- /dev/null +++ b/lib/Net/DBus/Tutorial/UsingObjects.pod @@ -0,0 +1,45 @@ +# -*- perl -*- +# +# Copyright (C) 2004-2005 Daniel P. Berrange +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# $Id: UsingObjects.pod,v 1.1 2006/02/03 13:34:18 dan Exp $ + +=pod + +=head1 NAME + +Net::DBus::Tutorial::UsingObjects - tutorial on accessing a DBus service + +=head1 DESCRIPTION + +This document provides a tutorial on accessing a DBus service using the +Perl Net::DBus application bindings. Sadly it is not yet written. + +=head1 SEE ALSO + +L for details of other tutorials, and +L for API documentation + +=head1 AUTHORS + +Daniel Berrange + +=head1 COPYRIGHT + +Copyright (C) 2006 Daniel P. Berrange + +=cut diff --git a/t/00-constants.t b/t/00-constants.t new file mode 100644 index 0000000..1281710 --- /dev/null +++ b/t/00-constants.t @@ -0,0 +1,41 @@ +# -*- perl -*- +use Test::More tests => 6; +BEGIN { + use_ok('Net::DBus::Binding::Watch'); + use_ok('Net::DBus::Binding::Message'); + use_ok('Net::DBus::Binding::Bus'); + }; + + +my $fail = 0; +foreach my $constname (qw( + SYSTEM SESSION STARTER)) { + next if (eval "my \$a = &Net::DBus::Binding::Bus::$constname; 1"); + print "# fail: $@"; + $fail = 1; +} +ok( $fail == 0 , 'Net::DBus::Binding::Bus Constants' ); + +$fail = 0; +foreach my $constname (qw( + TYPE_ARRAY TYPE_BOOLEAN + TYPE_BYTE TYPE_DOUBLE TYPE_STRUCT + TYPE_INT32 TYPE_INT64 TYPE_DICT_ENTRY + TYPE_INVALID TYPE_SIGNATURE TYPE_OBJECT_PATH + TYPE_STRING TYPE_UINT32 TYPE_UINT64)) { + next if (eval "my \$a = &Net::DBus::Binding::Message::$constname; 1"); + print "# fail: $@"; + $fail = 1; +} +ok( $fail == 0 , 'Net::DBus::Binding::Message Constants' ); + +$fail = 0; +foreach my $constname (qw( + READABLE WRITABLE + ERROR HANGUP)) { + next if (eval "my \$a = &Net::DBus::Binding::Watch::$constname; 1"); + print "# fail: $@"; + $fail = 1; +} + +ok( $fail == 0 , 'Net::DBus::Binding::Watch Constants' ); diff --git a/t/05-pod.t b/t/05-pod.t new file mode 100644 index 0000000..819ea48 --- /dev/null +++ b/t/05-pod.t @@ -0,0 +1,10 @@ +# -*- perl -*- + +use Test::More; + +use strict; +use warnings; + +eval "use Test::Pod 1.00"; +plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; +all_pod_files_ok(); diff --git a/t/10-pod-coverage.t b/t/10-pod-coverage.t new file mode 100644 index 0000000..fe076a7 --- /dev/null +++ b/t/10-pod-coverage.t @@ -0,0 +1,10 @@ +# -*- perl -*- + +use Test::More; + +use strict; +use warnings; + +eval "use Test::Pod::Coverage 1.00"; +plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@; +all_pod_coverage_ok(); diff --git a/t/15-message.t b/t/15-message.t new file mode 100644 index 0000000..d07c221 --- /dev/null +++ b/t/15-message.t @@ -0,0 +1,79 @@ +# -*- perl -*- +use Test::More tests => 33; + +use strict; +use warnings; + +BEGIN { + use_ok('Net::DBus::Binding::Iterator'); + use_ok('Net::DBus::Binding::Message::Signal'); + use_ok('Net::DBus::Binding::Message::MethodCall'); + use_ok('Net::DBus::Binding::Message::MethodReturn'); + use_ok('Net::DBus::Binding::Message::Error'); + }; + + +my $msg = Net::DBus::Binding::Message::Signal->new(object_path => "/foo/bar/Wizz", + interface => "com.blah.Example", + signal_name => "Eeek"); + +my $iter = $msg->iterator(1); +$iter->append_boolean(1); +$iter->append_byte(43); +$iter->append_int16(123); +$iter->append_uint16(456); +$iter->append_int32(123); +$iter->append_uint32(456); +$iter->append_int64("12345645645"); +$iter->append_uint64("12312312312"); +$iter->append_int64("12345645645123456"); +$iter->append_uint64("12312312312123456"); +$iter->append_string("Hello world"); +$iter->append_double(1.424141); + +$iter->append_array(["one", "two", "three"], [&Net::DBus::Binding::Message::TYPE_STRING]); + +$iter->append_dict({ "one" => "foo", "two" => "bar"}, [&Net::DBus::Binding::Message::TYPE_STRING, + &Net::DBus::Binding::Message::TYPE_STRING]); + +$iter = $msg->iterator(); +ok($iter->get_boolean() == 1, "boolean"); +ok($iter->next(), "next"); +ok($iter->get_byte() == 43, "byte"); +ok($iter->next(), "next"); + +ok($iter->get_int16() == 123, "int16"); +ok($iter->next(), "next"); +ok($iter->get_uint16() == 456, "uint16"); +ok($iter->next(), "next"); + +ok($iter->get_int32() == 123, "int32"); +ok($iter->next(), "next"); +ok($iter->get_uint32() == 456, "uint32"); +ok($iter->next(), "next"); + +ok($iter->get_int64() == "12345645645", "int64"); +ok($iter->next(), "next"); +ok($iter->get_uint64() == "12312312312", "uint64"); +ok($iter->next(), "next"); + +ok($iter->get_int64() == "12345645645123456", "int64"); +ok($iter->next(), "next"); +ok($iter->get_uint64() == "12312312312123456", "uint64"); +ok($iter->next(), "next"); + +ok($iter->get_string() eq "Hello world", "string"); +ok($iter->next(), "next"); +# Don't test precise equality, because floating point arithmetic +# is not an exact science. (see RT #37707) +my $d = $iter->get_double(); +ok($d > 1.424100 && $d < 1.424200, "double"); + +ok($iter->next(), "next"); +is_deeply($iter->get_array(&Net::DBus::Binding::Message::TYPE_STRING), ["one", "two", "three"], "array"); + +ok($iter->next(), "next"); +is_deeply($iter->get_dict(), {"one" => "foo", "two" => "bar"}, "dict"); + +ok(!$iter->next(), "next"); + diff --git a/t/20-callback.t b/t/20-callback.t new file mode 100644 index 0000000..7e62f07 --- /dev/null +++ b/t/20-callback.t @@ -0,0 +1,69 @@ +# -*- perl -*- +use Test::More tests => 5; + +use strict; +use warnings; + +BEGIN { + use_ok('Net::DBus::Callback'); +}; + +my $doneit = 0; + +my $doer = Doer->new; + +my $callback = Net::DBus::Callback->new( + object => $doer, + method => "doit", + args => [4, 3, 5] + ); + +$callback->invoke(); +ok($doer->doneit == 12, "object callback"); + +$callback->invoke(); +ok($doer->doneit == 24, "object callback"); + +$callback = Net::DBus::Callback->new( + method => \&doit, + args => [5,1,2] + ); + +$callback->invoke(); +ok($doneit == 8, "subroutine callback"); + +$callback->invoke(); +ok($doneit == 16, "subroutine callback"); + +sub doit { + foreach (@_) { + $doneit += $_; + } +} + +package Doer; + + +sub new { + my $class = shift; + my $self = {}; + + $self->{doneit} = 0; + + bless $self, $class; + + return $self; +} + +sub doit { + my $self = shift; + + foreach (@_) { + $self->{doneit} += $_; + } +} + +sub doneit { + my $self = shift; + return $self->{doneit}; +} diff --git a/t/25-reactor.t b/t/25-reactor.t new file mode 100644 index 0000000..b7917be --- /dev/null +++ b/t/25-reactor.t @@ -0,0 +1,122 @@ +# -*- perl -*- +use Test::More tests => 16; +use POSIX qw(pipe read write); +use strict; +use warnings; + +# The tests for timeouts will only work +# reliably on unloaded machine + +BEGIN { + use_ok('Net::DBus::Reactor'); + use_ok('Net::DBus::Callback'); +}; + + +my $reactor = Net::DBus::Reactor->new(); + +my $started = $reactor->_now; +my $fired; +my $alarmed; + +my $tid = $reactor->add_timeout(2000, + Net::DBus::Callback->new(method => \&timeout, args => []), + 1); + +$SIG{ALRM} = sub { $alarmed = 1 }; + +# Alarm just in case something goes horribly wrong +alarm 5; +$reactor->run; +alarm 0; + +ok (!$alarmed, "not alarmed"); +ok (defined $fired, "timeout fired"); + +# Timing is tricky, so just check a reasonble range +ok(($fired-$started) > 1900 && + ($fired-$started) < 3000, "timeout in range 1900->3000"); + +sub timeout { + $fired = $reactor->_now; + $reactor->shutdown; +} + +$reactor->remove_timeout($tid); + +my ($r1, $w1) = pipe; +my ($r2, $w2) = pipe; + +write $w1, "1", 1; + +my ($r1c, $w1c, $r2c, $w2c) = (0,0,0,0); +my $hookc = 0; + +$reactor->add_read($r1, + Net::DBus::Callback->new(method => \&do_r1)); +$reactor->add_write($w1, + Net::DBus::Callback->new(method => \&do_w1), + 0); +$reactor->add_read($r2, + Net::DBus::Callback->new(method => \&do_r2)); +$reactor->add_write($w2, + Net::DBus::Callback->new(method => \&do_w2), + 0); + +$reactor->add_hook(Net::DBus::Callback->new(method => \&hook)); + +$reactor->{running} = 1; +$reactor->step; + +ok($r1c == 1, "read one byte a"); +ok($r2c == 0, "not read one byte b"); +ok($hookc == 1, "hook 1\n"); + +write $w1, "11", 2; +write $w2, "1", 1; + +$reactor->{running} = 1; +$reactor->step; + +ok($r1c == 2, "read 2 byte a"); +ok($r2c == 1, "read one byte b"); +ok($hookc == 2, "hook 2\n"); + +$reactor->{running} = 1; +$reactor->step; + +ok($r1c == 3, "read 2 byte a"); +ok($hookc == 3, "hook 3\n"); + +$reactor->toggle_write($w1, 1); +$reactor->toggle_write($w2, 1); + +$reactor->{running} = 1; +$reactor->step; + +ok($w1c == 1, "write 1 byte a"); +ok($w2c == 1, "write 1 byte b"); +ok($hookc == 4, "hook 4\n"); + + +sub do_r1 { + my $buf; + $r1c += read $r1, $buf, 1; +} + +sub do_w1 { + $w1c += write $w1, "1", 1; +} + +sub do_r2 { + my $buf; + $r2c += read $r2, $buf, 1; +} + +sub do_w2 { + $w2c += write $w2, "1", 1; +} + +sub hook { + $hookc++; +} diff --git a/t/30-server.t b/t/30-server.t new file mode 100644 index 0000000..80f0b86 --- /dev/null +++ b/t/30-server.t @@ -0,0 +1,46 @@ +# -*- perl -*- +use Test::More tests => 11; + +use strict; +use warnings; + +BEGIN { + use_ok('Net::DBus::Binding::Server'); + use_ok('Net::DBus::Binding::Connection'); + use_ok('Net::DBus::Reactor'); + use_ok('Net::DBus::Binding::Message::Signal'); +} + + +my $server = Net::DBus::Binding::Server->new(address => "unix:path=/tmp/dbus-perl-test-$$"); +ok ($server->is_connected, "server connected"); + +my $reactor = Net::DBus::Reactor->new(); +$reactor->manage($server); + +my $incoming; +$server->set_connection_callback(sub { + $server = shift; + $incoming = shift; +}); + +my $client = Net::DBus::Binding::Connection->new(address => "unix:path=/tmp/dbus-perl-test-$$", + private => 1); +ok ($client->is_connected, "client connected"); +$reactor->manage($client); + +$reactor->{running} = 1; +$reactor->step; + +ok (defined $incoming, "incoming"); +ok ($incoming->is_connected, "incoming connected"); +#$reactor->manage($incoming); + +$client->disconnect; +ok (!$client->is_connected, "client disconnected"); + +$incoming->disconnect; +ok (!$incoming->is_connected, "incoming disconnected"); + +$server->disconnect; +ok (!$server->is_connected, "server disconnected"); diff --git a/t/40-introspector.t b/t/40-introspector.t new file mode 100644 index 0000000..dd88baa --- /dev/null +++ b/t/40-introspector.t @@ -0,0 +1,190 @@ +# -*- perl -*- +use Test::More tests => 6; + +use strict; +use warnings; + +BEGIN { + use_ok('Net::DBus::Binding::Introspector'); + }; + + +TEST_ONE: { + my $other_object = Net::DBus::Binding::Introspector->new( + object_path => "org.example.Object.OtherObject", + interfaces => { + "org.example.SomeInterface" => { + methods => { + "hello" => { + params => ["int32", "int32", ["struct", "int32","byte"]], + returns => ["int32"], + paramnames => ["wibble", "eek"], + returnnames => ["frob"], + }, + "goodbye" => { + params => [["array", ["struct", "int32", "string"]]], + returns => ["string", "string"], + paramnames => ["ooh"], + returnnames => ["ahh", "eek"], + }, + }, + signals => { + "meltdown" => { + params => ["int32", "byte"], + } + }, + props => { + "name" => { type => "string", access => "readwrite"}, + "email" => { type => "string", access => "read"}, + "age" => { type => "int32", access => "read"}, + "parents" => { type => ["array", "string"], access => "readwrite" }, + }, + } + }); + + isa_ok($other_object, "Net::DBus::Binding::Introspector"); + + my $other_xml_got = $other_object->format(); + + my $other_xml_expect = < + + + + + + + + + + + + + + + + + + + + + + + +EOF + is($other_xml_got, $other_xml_expect, "xml data matches"); + + my $object = Net::DBus::Binding::Introspector->new( + object_path => "org.example.Object", + interfaces => { + "org.example.SomeInterface" => { + methods => { + "hello" => { + params => ["int32", "int32", ["struct", "int32","byte"]], + returns => ["uint32"], + paramnames => [], + returnnames => [], + }, + "goodbye" => { + params => [["array", ["dict", "int32", "string"]]], + returns => ["string", ["array", "string"]], + paramnames => [], + returnnames => [], + }, + }, + signals => { + "meltdown" => { + params => ["int32", "byte"], + paramnames => [], + } + }, + }, + "org.example.OtherInterface" => { + methods => { + "hitme" => { + params => ["int32", "uint32"], + return => [], + paramnames => [], + returnnames => [], + } + }, + props => { + "title" => { type => "string", access => "readwrite"}, + "salary" => { type => "int32", access => "read"}, + }, + }, + }, + children => [ + "org.example.Object.SubObject", + $other_object, + ]); + + isa_ok($object, "Net::DBus::Binding::Introspector"); + + my $object_xml_got = $object->format(); + + my $object_xml_expect = < + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +EOF + is($object_xml_got, $object_xml_expect, "xml data matches"); + + + my $recon_other = Net::DBus::Binding::Introspector->new(xml => $object_xml_got); + + my $object_xml_got_again = $recon_other->format(); + + is($object_xml_got_again, $object_xml_expect, "reconstructed xml matches"); +} diff --git a/t/42-object-introspect-avahi.t b/t/42-object-introspect-avahi.t new file mode 100644 index 0000000..f36851f --- /dev/null +++ b/t/42-object-introspect-avahi.t @@ -0,0 +1,98 @@ +# -*- perl -*- +use Test::More tests => 10; + +use strict; +use warnings; + +BEGIN { + use_ok('Net::DBus::Binding::Introspector'); +}; + +local $/ = undef; +my $xml = ; + +my $introspector = Net::DBus::Binding::Introspector->new(object_path => "/org/freedesktop/Avahi/ServiceBrowser", + xml => $xml); + +isa_ok($introspector, "Net::DBus::Binding::Introspector"); + +ok($introspector->has_interface("org.freedesktop.DBus.Introspectable"), + "org.freedesktop.DBus.Introspectable interface present"); + +ok($introspector->has_interface("org.freedesktop.Avahi.ServiceBrowser"), + "org.freedesktop.Avahi.ServiceBrowser interface present"); + +ok($introspector->has_method("Free"), "Free method present"); +ok($introspector->has_signal("ItemNew"), "ItemNew signal present"); +ok($introspector->has_signal("ItemRemove"), "ItemRemove signal present"); +ok($introspector->has_signal("Failure"), "Failure signal present"); +ok($introspector->has_signal("AllForNow"), "AllForNow signal present"); +ok($introspector->has_signal("CacheExhausted"), "CacheExhausted signal present"); + + +__DATA__ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/t/45-exporter.t b/t/45-exporter.t new file mode 100644 index 0000000..3c8e616 --- /dev/null +++ b/t/45-exporter.t @@ -0,0 +1,224 @@ +# -*- perl -*- + +use Test::More tests => 94; + +use strict; +use warnings; + +package MyObject1; + +use strict; +use warnings; +use Test::More; +use base qw(Net::DBus::Object); +use Net::DBus; +use Net::DBus::Service; + +use Net::DBus::Exporter qw(org.example.MyObject); + +my $bus = Net::DBus->test; +my $service = $bus->export_service("org.example.MyService"); +my $obj = MyObject1->new($service, "/org/example/MyObject"); + +# First the full APIs +dbus_method("Everything", ["string"], ["int32"]); +dbus_method("EverythingInterface", ["string"], ["int32"], "org.example.OtherObject"); + +# Now add in annotations to the mix +dbus_method("EverythingAnnotate", ["string"], ["int32"], { deprecated => 1, + no_return => 1 }); +dbus_method("EverythingNegativeAnnotate", ["string"], ["int32"], { deprecated => 0, + no_return => 0 }); +dbus_method("EverythingInterfaceAnnotate", ["string"], ["int32"], "org.example.OtherObject", { deprecated => 1, + no_return => 1 }); +dbus_method("EverythingInterfaceNegativeAnnotate", ["string"], ["int32"], "org.example.OtherObject", { deprecated => 0, + no_return => 0 }); + +# Now test 'defaults' +dbus_method("NoArgsReturns"); +dbus_method("NoReturns", ["string"], [], { param_names => ["wizz"] }); +dbus_method("NoArgs",[],["int32"]); +dbus_method("NoArgsReturnsInterface", "org.example.OtherObject"); +dbus_method("NoReturnsInterface", ["string"], "org.example.OtherObject"); +dbus_method("NoArgsInterface", [],["int32"], "org.example.OtherObject"); + +dbus_method("NoArgsReturnsAnnotate", { deprecated => 1 }); +dbus_method("NoReturnsAnnotate", ["string"], { deprecated => 1 }); +dbus_method("NoArgsAnnotate",[],["int32"], { deprecated => 1 }); +dbus_method("NoArgsReturnsInterfaceAnnotate", "org.example.OtherObject", { deprecated => 1 }); +dbus_method("NoReturnsInterfaceAnnotate", ["string"], "org.example.OtherObject", { deprecated => 1, param_names => ["one"] }); +dbus_method("NoArgsInterfaceAnnotate", [],["int32"], "org.example.OtherObject", { deprecated => 1, return_names => ["two"] }); + +dbus_method("DemoInterfaceName1", [], ["string"], "_org.example._some_9object"); + +eval { + dbus_method("DemoInterfaceName2", [], ["string"], "9org.example.SomeObject"); +}; +ok($@ ne "", "raised error for leading digit in interface"); + +my $ins = Net::DBus::Exporter::_dbus_introspector(ref($obj)); + +ok($ins->has_interface("org.example.MyObject"), "interface registration"); +ok(!$ins->has_interface("org.example.BogusObject"), "-ve interface registration"); + +my $wantxml = < + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +EOF + +is ($ins->format($obj), $wantxml, "xml matches"); + + +&check_method($ins, "Everything", ["string"], ["int32"], "org.example.MyObject", 0, 0); +&check_method($ins, "EverythingInterface", ["string"], ["int32"], "org.example.OtherObject", 0, 0); +&check_method($ins, "EverythingAnnotate", ["string"], ["int32"], "org.example.MyObject", 1, 1); +&check_method($ins, "EverythingNegativeAnnotate", ["string"], ["int32"], "org.example.MyObject", 0, 0); +&check_method($ins, "EverythingInterfaceAnnotate", ["string"], ["int32"], "org.example.OtherObject", 1, 1); +&check_method($ins, "EverythingInterfaceNegativeAnnotate", ["string"], ["int32"], "org.example.OtherObject", 0, 0); + +&check_method($ins, "NoArgsReturns", [], [], "org.example.MyObject", 0, 0); +&check_method($ins, "NoReturns", ["string"], [], "org.example.MyObject", 0, 0); +&check_method($ins, "NoArgs", [], ["int32"], "org.example.MyObject", 0, 0); +&check_method($ins, "NoArgsReturnsInterface", [], [], "org.example.OtherObject", 0, 0); +&check_method($ins, "NoReturnsInterface", ["string"], [], "org.example.OtherObject", 0, 0); +&check_method($ins, "NoArgsInterface", [], ["int32"], "org.example.OtherObject", 0, 0); + +&check_method($ins, "NoArgsReturnsAnnotate", [], [], "org.example.MyObject", 1, 0); +&check_method($ins, "NoReturnsAnnotate", ["string"], [], "org.example.MyObject", 1, 0); +&check_method($ins, "NoArgsAnnotate", [], ["int32"], "org.example.MyObject", 1, 0); +&check_method($ins, "NoArgsReturnsInterfaceAnnotate", [], [], "org.example.OtherObject", 1, 0); +&check_method($ins, "NoReturnsInterfaceAnnotate", ["string"], [], "org.example.OtherObject", 1, 0); +&check_method($ins, "NoArgsInterfaceAnnotate", [], ["int32"], "org.example.OtherObject", 1, 0); + + +sub check_method { + my $ins = shift; + my $name = shift; + my $params = shift; + my $returns = shift; + my $interface = shift; + my $deprecated = shift; + my $no_return = shift; + + my @interfaces = $ins->has_method($name); + is_deeply([$interface], \@interfaces, "method interface mapping"); + + my @params = $ins->get_method_params($interface, $name); + is_deeply($params, \@params, "method parameters"); + + my @returns = $ins->get_method_returns($interface, $name); + is_deeply($returns, \@returns, "method returneters"); + + if ($deprecated) { + ok($ins->is_method_deprecated($name, $interface), "method deprecated"); + } else { + ok(!$ins->is_method_deprecated($name, $interface), "method deprecated"); + } + + + if ($no_return) { + ok(!$ins->does_method_reply($name, $interface), "method no reply"); + } else { + ok($ins->does_method_reply($name, $interface), "method no reply"); + } + + +} diff --git a/t/50-object-introspect.t b/t/50-object-introspect.t new file mode 100644 index 0000000..47e0261 --- /dev/null +++ b/t/50-object-introspect.t @@ -0,0 +1,50 @@ +# -*- perl -*- +use Test::More tests => 3; + +use strict; +use warnings; + +BEGIN { + use_ok('Net::DBus::Binding::Introspector'); + use_ok('Net::DBus::Object'); +}; + +my $bus = Net::DBus->test; +my $service = $bus->export_service("/org/cpan/Net/DBus/Test/introspect"); + +my $object = Net::DBus::Object->new($service, "/org/example/Object/OtherObject"); + +my $introspector = $object->_introspector; + +my $xml_got = $introspector->format($object); + +my $xml_expect = < + + + + + + + + + + + + + + + + + + + + + + + +EOF + +is($xml_got, $xml_expect, "xml data matches"); + diff --git a/t/55-method-calls.t b/t/55-method-calls.t new file mode 100644 index 0000000..6c89e04 --- /dev/null +++ b/t/55-method-calls.t @@ -0,0 +1,161 @@ +# -*- perl -*- + +use Test::More tests => 56; + +use strict; +use warnings; + +BEGIN { + use_ok('Net::DBus::Binding::Introspector') or die; + use_ok('Net::DBus::Object') or die; + use_ok('Net::DBus::Test::MockObject') or die; +}; + + +TEST_NO_INTROSPECT: { + my ($bus, $object, $robject, $myobject, $otherobject) = &setup; + + $object->seed_action("org.freedesktop.DBus.Introspectable", "Introspect", + error => { name => "org.freedesktop.DBus.Error.Failed", + description => "No such method" }); + + &test_method_fail("raw, no introspect", $robject, "Test"); + &test_method_reply("myobject, no introspect",$myobject, "Test", "TestedMyObject"); + &test_method_fail("otherobject, no introspect",$otherobject, "Test"); + + &test_method_fail("raw, no introspect",$robject, "Bogus"); + &test_method_fail("myobject, no introspect",$myobject, "Bogus"); + &test_method_fail("otherobject, no introspect",$otherobject, "Bogus"); + + &test_method_fail("raw, no introspect",$robject, "PolyTest"); + &test_method_reply("myobject, no introspect",$myobject, "PolyTest", "PolyTestedMyObject"); + &test_method_reply("otherobject, no introspect",$otherobject, "PolyTest", "PolyTestedOtherObject"); + + &test_method_fail("raw, no introspect", $robject, "Deprecated"); + &test_method_reply("myobject, no introspect",$myobject, "Deprecated", "TestedDeprecation"); + &test_method_fail("otherobject, no introspect",$otherobject, "Deprecated"); +} + +TEST_MISSING_INTROSPECT: { + my ($bus, $object, $robject, $myobject, $otherobject) = &setup; + + my $ins = Net::DBus::Binding::Introspector->new(object_path => $object->get_object_path); + $object->seed_action("org.freedesktop.DBus.Introspectable", "Introspect", + reply => { return => [ $ins->format ] }); + + + &test_method_fail("raw, missing introspect",$robject, "Test"); + &test_method_reply("myobject, missing introspect",$myobject, "Test", "TestedMyObject"); + &test_method_fail("otherobject, missing introspect",$otherobject, "Test"); + + &test_method_fail("raw, missing introspect",$robject, "Bogus"); + &test_method_fail("myobject, missing introspect",$myobject, "Bogus"); + &test_method_fail("otherobject, missing introspect",$otherobject, "Bogus"); + + &test_method_fail("raw, missing introspect",$robject, "PolyTest"); + &test_method_reply("myobject, missing introspect",$myobject, "PolyTest", "PolyTestedMyObject"); + &test_method_reply("otherobject, missing introspect",$otherobject, "PolyTest", "PolyTestedOtherObject"); + + &test_method_fail("raw, no introspect", $robject, "Deprecated"); + &test_method_reply("myobject, no introspect",$myobject, "Deprecated", "TestedDeprecation"); + &test_method_fail("otherobject, no introspect",$otherobject, "Deprecated"); +} + +TEST_FULL_INTROSPECT: { + my ($bus, $object, $robject, $myobject, $otherobject) = &setup; + + my $ins = Net::DBus::Binding::Introspector->new(object_path => $object->get_object_path); + $ins->add_method("Test", [], ["string"], "org.example.MyObject", {}, []); + $ins->add_method("PolyTest", [], ["string"], "org.example.MyObject", {}, []); + $ins->add_method("PolyTest", [], ["string"], "org.example.OtherObject", {}, []); + $ins->add_method("Deprecated", [], ["string"], "org.example.MyObject", { deprecated => 1 }, []); + $object->seed_action("org.freedesktop.DBus.Introspectable", "Introspect", + reply => { return => [ $ins->format ] }); + + + &test_method_reply("raw, full introspect",$robject, "Test", "TestedMyObject"); + &test_method_reply("myobject, full introspect",$myobject, "Test", "TestedMyObject"); + &test_method_fail("otherobject, full introspect",$otherobject, "Test"); + + &test_method_fail("raw, full introspect",$robject, "Bogus"); + &test_method_fail("myobject, full introspect",$myobject, "Bogus"); + &test_method_fail("otherobject, full introspect",$otherobject, "Bogus"); + + &test_method_fail("raw, full introspect",$robject, "PolyTest"); + &test_method_reply("myobject, full introspect",$myobject, "PolyTest", "PolyTestedMyObject"); + &test_method_reply("otherobject, full introspect",$otherobject, "PolyTest", "PolyTestedOtherObject"); + + { + my $warned = 0; + local $SIG{__WARN__} = sub { + if ($_[0] eq "method 'Deprecated' in interface org.example.MyObject on object /org/example/MyObject is deprecated\n") { + $warned = 1; + } + }; + &test_method_reply("raw, no introspect", $robject, "Deprecated", "TestedDeprecation"); + ok($warned, "deprecation warning generated"); + $warned = 0; + &test_method_reply("myobject, no introspect",$myobject, "Deprecated", "TestedDeprecation"); + ok($warned, "deprecation warning generated"); + $warned = 0; + &test_method_fail("otherobject, no introspect",$otherobject, "Deprecated"); + ok(!$warned, "deprecation warning generated"); + } +} + + +sub setup { + my $bus = Net::DBus->test; + my $service = $bus->export_service("org.cpan.Net.Bus.test"); + + my $object = Net::DBus::Test::MockObject->new($service, "/org/example/MyObject"); + + my $rservice = $bus->get_service("org.cpan.Net.Bus.test"); + my $robject = $rservice->get_object("/org/example/MyObject"); + my $myobject = $robject->as_interface("org.example.MyObject"); + my $otherobject = $robject->as_interface("org.example.OtherObject"); + + $object->seed_action("org.example.MyObject", "Test", reply => { return => [ "TestedMyObject" ] }); + $object->seed_action("org.example.MyObject", "PolyTest", reply => { return => [ "PolyTestedMyObject" ] }); + $object->seed_action("org.example.OtherObject", "PolyTest", reply => { return => [ "PolyTestedOtherObject" ] }); + $object->seed_action("org.example.MyObject", "Deprecated", reply => { return => [ "TestedDeprecation" ]}); + $object->seed_action("org.example.MyObject", "TestNoReturn"); + + return ($bus, $object, $robject, $myobject, $otherobject); +} + +sub test_method_noreply { + my $tag = shift; + my $object = shift; + my $method = shift; + + my $actual = eval { + $object->$method; + }; + is($@, "", "error is not thrown by '$method' ($tag)"); + ok(!$actual, "return from '$method' is undefined ($tag)"); +} + +sub test_method_reply { + my $tag = shift; + my $object = shift; + my $method = shift; + my $expect = shift; + + my $actual = eval { + $object->$method; + }; + is($@, "", "error is not thrown by '$method' ($tag)"); + is($actual, $expect, "return from '$method' is '$actual' ($tag)"); +} + +sub test_method_fail { + my $tag = shift; + my $object = shift; + my $method = shift; + + my $actual = eval { + $object->$method; + }; + ok($@, "error is thrown by '$method' ($tag)"); +} diff --git a/t/56-scalar-param-typing.t b/t/56-scalar-param-typing.t new file mode 100644 index 0000000..98d12ff --- /dev/null +++ b/t/56-scalar-param-typing.t @@ -0,0 +1,1133 @@ +# -*- perl -*- + +use Test::More tests => 382; + +use Carp qw(confess); +$SIG{__DIE__} = sub { confess $_[0] }; +use strict; +use warnings; + +BEGIN { + use_ok('Net::DBus::Binding::Introspector') or die; + use_ok('Net::DBus::Object') or die; + use_ok('Net::DBus::Test::MockObject') or die; + use_ok("Net::DBus", qw(:typing)) or die; +}; + +TEST_NO_INTROSPECT: { + my ($bus, $object, $robject, $myobject, $otherobject) = &setup; + + ##### String tests + + $myobject->ScalarString("Foo"); + is($object->get_last_message_signature, "s", "string as string"); + is($object->get_last_message_param, "Foo", "string as string"); + + $myobject->ScalarString(2); + is($object->get_last_message->get_signature, "s", "int as string"); + is($object->get_last_message_param, "2", "int as string"); + + $myobject->ScalarString(5.234); + is($object->get_last_message->get_signature, "s", "double as string"); + is($object->get_last_message_param, "5.234", "double as string"); + + + #### INT 16 tests + + # Positive integers + $myobject->ScalarInt16("2"); + is($object->get_last_message_signature, "s", "string as int16"); + is($object->get_last_message_param, "2", "string as int16"); + + $myobject->ScalarInt16(2); + is($object->get_last_message_signature, "s", "int as int16"); + is($object->get_last_message_param, "2", "int as int16"); + + $myobject->ScalarInt16(2.0); + is($object->get_last_message_signature, "s", "double as int16"); + is($object->get_last_message_param, "2", "double as int16"); + + # Negative integers + $myobject->ScalarInt16("-2"); + is($object->get_last_message_signature, "s", "-ve string as int16"); + is($object->get_last_message_param, "-2", "-ve string as int16"); + + $myobject->ScalarInt16(-2); + is($object->get_last_message_signature, "s", "-ve int as int16"); + is($object->get_last_message_param, "-2", "-ve int as int16"); + + $myobject->ScalarInt16(-2.0); + is($object->get_last_message_signature, "s", "-ve double as int16"); + is($object->get_last_message_param, "-2", "-ve double as int16"); + + # Rounding of doubles + $myobject->ScalarInt16(2.1); + is($object->get_last_message_signature, "s", "round down double as int16"); + is($object->get_last_message_param, "2.1", "round down double as int16"); + + $myobject->ScalarInt16(2.9); + is($object->get_last_message_signature, "s", "round up double as int16"); + is($object->get_last_message_param, "2.9", "round up double as int16"); + + $myobject->ScalarInt16(2.5); + is($object->get_last_message_signature, "s", "round up double threshold as int16"); + is($object->get_last_message_param, "2.5", "round up double threshold as int16"); + + $myobject->ScalarInt16(-2.1); + is($object->get_last_message_signature, "s", "-ve round up double as int16"); + is($object->get_last_message_param, "-2.1", "-ve round up double as int16"); + + $myobject->ScalarInt16(-2.9); + is($object->get_last_message_signature, "s", "-ve round down double as int16"); + is($object->get_last_message_param, "-2.9", "-ve round down double as int16"); + + $myobject->ScalarInt16(-2.5); + is($object->get_last_message_signature, "s", "-ve round down double threshold as int16"); + is($object->get_last_message_param, "-2.5", "-ve round down double threshold as int16"); + + + #### UINT 16 tests + + # Positive integers + $myobject->ScalarUInt16("2"); + is($object->get_last_message_signature, "s", "string as uint16"); + is($object->get_last_message_param, "2", "string as uint16"); + + $myobject->ScalarUInt16(2); + is($object->get_last_message_signature, "s", "int as uint16"); + is($object->get_last_message_param, "2", "int as uint16"); + + $myobject->ScalarUInt16(2.0); + is($object->get_last_message_signature, "s", "double as uint16"); + is($object->get_last_message_param, "2", "double as uint16"); + + # Negative integers + $myobject->ScalarUInt16("-2"); + is($object->get_last_message_signature, "s", "-ve string as uint16"); + is($object->get_last_message_param, "-2", "-ve string as uint16"); + + $myobject->ScalarUInt16(-2); + is($object->get_last_message_signature, "s", "-ve int as uint16"); + is($object->get_last_message_param, "-2", "-ve int as uint16"); + + $myobject->ScalarUInt16(-2.0); + is($object->get_last_message_signature, "s", "-ve double as uint16"); + is($object->get_last_message_param, "-2", "-ve double as uint16"); + + + # Rounding of doubles + $myobject->ScalarUInt16(2.1); + is($object->get_last_message_signature, "s", "round down double as uint16"); + is($object->get_last_message_param, "2.1", "round down double as uint16"); + + $myobject->ScalarUInt16(2.9); + is($object->get_last_message_signature, "s", "round up double as uint16"); + is($object->get_last_message_param, "2.9", "round up double as uint16"); + + $myobject->ScalarUInt16(2.5); + is($object->get_last_message_signature, "s", "round up double threshold as uint16"); + is($object->get_last_message_param, "2.5", "round up double threshold as uint16"); + + + #### INT 32 tests + + # Positive integers + $myobject->ScalarInt32("2"); + is($object->get_last_message_signature, "s", "string as int32"); + is($object->get_last_message_param, "2", "string as int32"); + + $myobject->ScalarInt32(2); + is($object->get_last_message_signature, "s", "int as int32"); + is($object->get_last_message_param, "2", "int as int32"); + + $myobject->ScalarInt32(2.0); + is($object->get_last_message_signature, "s", "double as int32"); + is($object->get_last_message_param, "2", "double as int32"); + + # Negative integers + $myobject->ScalarInt32("-2"); + is($object->get_last_message_signature, "s", "-ve string as int32"); + is($object->get_last_message_param, "-2", "-ve string as int32"); + + $myobject->ScalarInt32(-2); + is($object->get_last_message_signature, "s", "-ve int as int32"); + is($object->get_last_message_param, "-2", "-ve int as int32"); + + $myobject->ScalarInt32(-2.0); + is($object->get_last_message_signature, "s", "-ve double as int32"); + is($object->get_last_message_param, "-2", "-ve double as int32"); + + # Rounding of doubles + $myobject->ScalarInt32(2.1); + is($object->get_last_message_signature, "s", "round down double as int32"); + is($object->get_last_message_param, "2.1", "round down double as int32"); + + $myobject->ScalarInt32(2.9); + is($object->get_last_message_signature, "s", "round up double as int32"); + is($object->get_last_message_param, "2.9", "round up double as int32"); + + $myobject->ScalarInt32(2.5); + is($object->get_last_message_signature, "s", "round up double threshold as int32"); + is($object->get_last_message_param, "2.5", "round up double threshold as int32"); + + $myobject->ScalarInt32(-2.1); + is($object->get_last_message_signature, "s", "-ve round up double as int32"); + is($object->get_last_message_param, "-2.1", "-ve round up double as int32"); + + $myobject->ScalarInt32(-2.9); + is($object->get_last_message_signature, "s", "-ve round down double as int32"); + is($object->get_last_message_param, "-2.9", "-ve round down double as int32"); + + $myobject->ScalarInt32(-2.5); + is($object->get_last_message_signature, "s", "-ve round down double threshold as int32"); + is($object->get_last_message_param, "-2.5", "-ve round down double threshold as int32"); + + + #### UINT 32 tests + + # Positive integers + $myobject->ScalarUInt32("2"); + is($object->get_last_message_signature, "s", "string as uint32"); + is($object->get_last_message_param, "2", "string as uint32"); + + $myobject->ScalarUInt32(2); + is($object->get_last_message_signature, "s", "int as uint32"); + is($object->get_last_message_param, "2", "int as uint32"); + + $myobject->ScalarUInt32(2.0); + is($object->get_last_message_signature, "s", "double as uint32"); + is($object->get_last_message_param, "2", "double as uint32"); + + # Negative integers + $myobject->ScalarUInt32("-2"); + is($object->get_last_message_signature, "s", "-ve string as uint32"); + is($object->get_last_message_param, "-2", "-ve string as uint32"); + + $myobject->ScalarUInt32(-2); + is($object->get_last_message_signature, "s", "-ve int as uint32"); + is($object->get_last_message_param, "-2", "-ve int as uint32"); + + $myobject->ScalarUInt32(-2.0); + is($object->get_last_message_signature, "s", "-ve double as uint32"); + is($object->get_last_message_param, "-2", "-ve double as uint32"); + + + # Rounding of doubles + $myobject->ScalarUInt32(2.1); + is($object->get_last_message_signature, "s", "round down double as uint32"); + is($object->get_last_message_param, "2.1", "round down double as uint32"); + + $myobject->ScalarUInt32(2.9); + is($object->get_last_message_signature, "s", "round up double as uint32"); + is($object->get_last_message_param, "2.9", "round up double as uint32"); + + $myobject->ScalarUInt32(2.5); + is($object->get_last_message_signature, "s", "round up double threshold as uint32"); + is($object->get_last_message_param, "2.5", "round up double threshold as uint32"); + + + #### Double tests + + # Double + $myobject->ScalarDouble(5.234); + is($object->get_last_message_signature, "s", "double as double"); + is($object->get_last_message_param, "5.234", "double as double"); + + # Stringized Double + $myobject->ScalarDouble("2.1"); + is($object->get_last_message_signature, "s", "string as double"); + is($object->get_last_message_param, "2.1", "string as double"); + + # Integer -> double conversion + $myobject->ScalarDouble(2); + is($object->get_last_message_signature, "s", "int as double"); + is($object->get_last_message_param, "2", "int as double"); + + + # -ve Double + $myobject->ScalarDouble(-5.234); + is($object->get_last_message_signature, "s", "-ve double as double"); + is($object->get_last_message_param, "-5.234", "-ve double as double"); + + # -ve Stringized Double + $myobject->ScalarDouble("-2.1"); + is($object->get_last_message_signature, "s", "-ve string as double"); + is($object->get_last_message_param, "-2.1", "-ve string as double"); + + # -ve Integer -> double conversion + $myobject->ScalarDouble(-2); + is($object->get_last_message_signature, "s", "-ve int as double"); + is($object->get_last_message_param, "-2", "-ve int as double"); + + + #### Byte tests + + # Int + $myobject->ScalarByte(7); + is($object->get_last_message_signature, "s", "int as byte"); + is($object->get_last_message_param, "7", "int as byte"); + + # Double roudning + $myobject->ScalarByte(2.6); + is($object->get_last_message_signature, "s", "double as byte"); + is($object->get_last_message_param, "2.6", "double as byte"); + + # Range overflow + $myobject->ScalarByte(10000); + is($object->get_last_message_signature, "s", "int as byte overflow"); + is($object->get_last_message_param, "10000", "int as byte overflow"); + + + # -ve Int + $myobject->ScalarByte(-7); + is($object->get_last_message_signature, "s", "-ve int as byte"); + is($object->get_last_message_param, "-7", "-ve int as byte"); + + # -ve Double roudning + $myobject->ScalarByte(-2.6); + is($object->get_last_message_signature, "s", "double as byte"); + is($object->get_last_message_param, "-2.6", "double as byte"); + + # -ve Range overflow + $myobject->ScalarByte(-10000); + is($object->get_last_message_signature, "s", "-ve int as byte overflow"); + is($object->get_last_message_param, "-10000", "-ve int as byte overflow"); + + + ##### Boolean + + # String, O and false + $myobject->ScalarBoolean("0"); + is($object->get_last_message_signature, "s", "string as boolean, 0 and false"); + is($object->get_last_message_param, "0", "string as boolean, 0 and false"); + + # String, O but true + $myobject->ScalarBoolean("0true"); + is($object->get_last_message_signature, "s", "string as boolean, 0 but true"); + is($object->get_last_message_param, "0true", "string as boolean, 0 but true"); + + # String, 1 and true + $myobject->ScalarBoolean("1true"); + is($object->get_last_message_signature, "s", "string as boolean, 1 and true"); + is($object->get_last_message_param, "1true", "string as boolean, 1 and true"); + + # Int true + $myobject->ScalarBoolean(1); + is($object->get_last_message_signature, "s", "int as boolean, true"); + is($object->get_last_message_param, "1", "int as boolean, true"); + + # Int false + $myobject->ScalarBoolean(0); + is($object->get_last_message_signature, "s", "int as boolean, false"); + is($object->get_last_message_param, "0", "int as boolean, false"); + + # Undefined and false + $myobject->ScalarBoolean(undef); + is($object->get_last_message_signature, "s", "undefined as boolean, false"); + is($object->get_last_message_param, "", "undefined as boolean, false"); + +} + + + +TEST_MANUAL_TYPING: { + my ($bus, $object, $robject, $myobject, $otherobject) = &setup; + + ##### String tests + + $myobject->ScalarString("Foo"); + is($object->get_last_message_signature, "s", "string as string"); + is($object->get_last_message_param, "Foo", "string as string"); + + $myobject->ScalarString(2); + is($object->get_last_message->get_signature, "s", "int as string"); + is($object->get_last_message_param, "2", "int as string"); + + $myobject->ScalarString(5.234); + is($object->get_last_message->get_signature, "s", "double as string"); + is($object->get_last_message_param, "5.234", "double as string"); + + + #### INT 16 tests + + # Positive integers + $myobject->ScalarInt16(dbus_int16("2")); + is($object->get_last_message_signature, "n", "string as int16"); + is($object->get_last_message_param, 2, "string as int16"); + + $myobject->ScalarInt16(dbus_int16(2)); + is($object->get_last_message_signature, "n", "int as int16"); + is($object->get_last_message_param, 2, "int as int16"); + + $myobject->ScalarInt16(dbus_int16(2.0)); + is($object->get_last_message_signature, "n", "double as int16"); + is($object->get_last_message_param, 2, "double as int16"); + + # Negative integers + $myobject->ScalarInt16(dbus_int16("-2")); + is($object->get_last_message_signature, "n", "-ve string as int16"); + is($object->get_last_message_param, -2, "-ve string as int16"); + + $myobject->ScalarInt16(dbus_int16(-2)); + is($object->get_last_message_signature, "n", "-ve int as int16"); + is($object->get_last_message_param, -2, "-ve int as int16"); + + $myobject->ScalarInt16(dbus_int16(-2.0)); + is($object->get_last_message_signature, "n", "-ve double as int16"); + is($object->get_last_message_param, -2, "-ve double as int16"); + + # Rounding of doubles + $myobject->ScalarInt16(dbus_int16(2.1)); + is($object->get_last_message_signature, "n", "round down double as int16"); + is($object->get_last_message_param, 2, "round down double as int16"); + + $myobject->ScalarInt16(dbus_int16(2.9)); + is($object->get_last_message_signature, "n", "round up double as int16"); + SKIP: { + skip "rounding actually truncates", 1; + is($object->get_last_message_param, 3, "round up double as int16"); + } + $myobject->ScalarInt16(dbus_int16(2.5)); + is($object->get_last_message_signature, "n", "round up double threshold as int16"); + SKIP: { + skip "rounding actually truncates", 1; + is($object->get_last_message_param, 3, "round up double threshold as int16"); + } + + $myobject->ScalarInt16(dbus_int16(-2.1)); + is($object->get_last_message_signature, "n", "-ve round up double as int16"); + is($object->get_last_message_param, -2, "-ve round up double as int16"); + + $myobject->ScalarInt16(dbus_int16(-2.9)); + is($object->get_last_message_signature, "n", "-ve round down double as int16"); + SKIP: { + skip "rounding actually truncates", 1; + is($object->get_last_message_param, -3, "-ve round down double as int16"); + } + + $myobject->ScalarInt16(dbus_int16(-2.5)); + is($object->get_last_message_signature, "n", "-ve round down double threshold as int16"); + is($object->get_last_message_param, -2, "-ve round down double threshold as int16"); + + + #### UINT 16 tests + + # Positive integers + $myobject->ScalarUInt16(dbus_uint16("2")); + is($object->get_last_message_signature, "q", "string as uint16"); + is($object->get_last_message_param, 2, "string as uint16"); + + $myobject->ScalarUInt16(dbus_uint16(2)); + is($object->get_last_message_signature, "q", "int as uint16"); + is($object->get_last_message_param, 2, "int as uint16"); + + $myobject->ScalarUInt16(dbus_uint16(2.0)); + is($object->get_last_message_signature, "q", "double as uint16"); + is($object->get_last_message_param, 2, "double as uint16"); + + # Negative integers + $myobject->ScalarUInt16(dbus_uint16("-2")); + is($object->get_last_message_signature, "q", "-ve string as uint16"); + SKIP: { + skip "sign truncation is wrong", 1; + is($object->get_last_message_param, -2, "-ve string as uint16"); + } + + $myobject->ScalarUInt16(dbus_uint16(-2)); + is($object->get_last_message_signature, "q", "-ve int as uint16"); + SKIP: { + skip "sign truncation is wrong", 1; + is($object->get_last_message_param, -2, "-ve int as uint16"); + } + + $myobject->ScalarUInt16(dbus_uint16(-2.0)); + is($object->get_last_message_signature, "q", "-ve double as uint16"); + SKIP: { + skip "sign truncation is wrong", 1; + is($object->get_last_message_param, -2, "-ve double as uint16"); + } + + # Rounding of doubles + $myobject->ScalarUInt16(dbus_uint16(2.1)); + is($object->get_last_message_signature, "q", "round down double as uint16"); + is($object->get_last_message_param, 2, "round down double as uint16"); + + $myobject->ScalarUInt16(dbus_uint16(2.9)); + is($object->get_last_message_signature, "q", "round up double as uint16"); + SKIP: { + skip "rounding actually truncates", 1; + is($object->get_last_message_param, 3, "round up double as uint16"); + } + + $myobject->ScalarUInt16(dbus_uint16(2.5)); + is($object->get_last_message_signature, "q", "round up double threshold as uint16"); + SKIP: { + skip "rounding actually truncates", 1; + is($object->get_last_message_param, 3, "round up double threshold as uint16"); + } + + #### INT 32 tests + + # Positive integers + $myobject->ScalarInt32(dbus_int32("2")); + is($object->get_last_message_signature, "i", "string as int32"); + is($object->get_last_message_param, 2, "string as int32"); + + $myobject->ScalarInt32(dbus_int32(2)); + is($object->get_last_message_signature, "i", "int as int32"); + is($object->get_last_message_param, 2, "int as int32"); + + $myobject->ScalarInt32(dbus_int32(2.0)); + is($object->get_last_message_signature, "i", "double as int32"); + is($object->get_last_message_param, 2, "double as int32"); + + # Negative integers + $myobject->ScalarInt32(dbus_int32("-2")); + is($object->get_last_message_signature, "i", "-ve string as int32"); + is($object->get_last_message_param, -2, "-ve string as int32"); + + $myobject->ScalarInt32(dbus_int32(-2)); + is($object->get_last_message_signature, "i", "-ve int as int32"); + is($object->get_last_message_param, -2, "-ve int as int32"); + + $myobject->ScalarInt32(dbus_int32(-2.0)); + is($object->get_last_message_signature, "i", "-ve double as int32"); + is($object->get_last_message_param, -2, "-ve double as int32"); + + # Rounding of doubles + $myobject->ScalarInt32(dbus_int32(2.1)); + is($object->get_last_message_signature, "i", "round down double as int32"); + is($object->get_last_message_param, 2, "round down double as int32"); + + $myobject->ScalarInt32(dbus_int32(2.9)); + is($object->get_last_message_signature, "i", "round up double as int32"); + SKIP: { + skip "rounding actually truncates", 1; + is($object->get_last_message_param, 3, "round up double as int32"); + } + $myobject->ScalarInt32(dbus_int32(2.5)); + is($object->get_last_message_signature, "i", "round up double threshold as int32"); + SKIP: { + skip "rounding actually truncates", 1; + is($object->get_last_message_param, 3, "round up double threshold as int32"); + } + + $myobject->ScalarInt32(dbus_int32(-2.1)); + is($object->get_last_message_signature, "i", "-ve round up double as int32"); + is($object->get_last_message_param, -2, "-ve round up double as int32"); + + $myobject->ScalarInt32(dbus_int32(-2.9)); + is($object->get_last_message_signature, "i", "-ve round down double as int32"); + SKIP: { + skip "rounding actually truncates", 1; + is($object->get_last_message_param, -3, "-ve round down double as int32"); + } + + $myobject->ScalarInt32(dbus_int32(-2.5)); + is($object->get_last_message_signature, "i", "-ve round down double threshold as int32"); + is($object->get_last_message_param, -2, "-ve round down double threshold as int32"); + + + #### UINT 32 tests + + # Positive integers + $myobject->ScalarUInt32(dbus_uint32("2")); + is($object->get_last_message_signature, "u", "string as uint32"); + is($object->get_last_message_param, 2, "string as uint32"); + + $myobject->ScalarUInt32(dbus_uint32(2)); + is($object->get_last_message_signature, "u", "int as uint32"); + is($object->get_last_message_param, 2, "int as uint32"); + + $myobject->ScalarUInt32(dbus_uint32(2.0)); + is($object->get_last_message_signature, "u", "double as uint32"); + is($object->get_last_message_param, 2, "double as uint32"); + + # Negative integers + $myobject->ScalarUInt32(dbus_uint32("-2")); + is($object->get_last_message_signature, "u", "-ve string as uint32"); + SKIP: { + skip "sign truncation is wrong", 1; + is($object->get_last_message_param, -2, "-ve string as uint32"); + } + + $myobject->ScalarUInt32(dbus_uint32(-2)); + is($object->get_last_message_signature, "u", "-ve int as uint32"); + SKIP: { + skip "sign truncation is wrong", 1; + is($object->get_last_message_param, -2, "-ve int as uint32"); + } + + $myobject->ScalarUInt32(dbus_uint32(-2.0)); + is($object->get_last_message_signature, "u", "-ve double as uint32"); + SKIP: { + skip "sign truncation is wrong", 1; + is($object->get_last_message_param, -2, "-ve double as uint32"); + } + + # Rounding of doubles + $myobject->ScalarUInt32(dbus_uint32(2.1)); + is($object->get_last_message_signature, "u", "round down double as uint32"); + is($object->get_last_message_param, 2, "round down double as uint32"); + + $myobject->ScalarUInt32(dbus_uint32(2.9)); + is($object->get_last_message_signature, "u", "round up double as uint32"); + SKIP: { + skip "rounding actually truncates", 1; + is($object->get_last_message_param, 3, "round up double as uint32"); + } + + $myobject->ScalarUInt32(dbus_uint32(2.5)); + is($object->get_last_message_signature, "u", "round up double threshold as uint32"); + SKIP: { + skip "rounding actually truncates", 1; + is($object->get_last_message_param, 3, "round up double threshold as uint32"); + } + + #### Double tests + + # Double + $myobject->ScalarDouble(dbus_double(5.234)); + is($object->get_last_message_signature, "d", "double as double"); + is($object->get_last_message_param, 5.234, "double as double"); + + # Stringized Double + $myobject->ScalarDouble(dbus_double("2.1")); + is($object->get_last_message_signature, "d", "string as double"); + is($object->get_last_message_param, 2.1, "string as double"); + + # Integer -> double conversion + $myobject->ScalarDouble(dbus_double(2)); + is($object->get_last_message_signature, "d", "int as double"); + is($object->get_last_message_param, 2.0, "int as double"); + + + # -ve Double + $myobject->ScalarDouble(dbus_double(-5.234)); + is($object->get_last_message_signature, "d", "-ve double as double"); + is($object->get_last_message_param, -5.234, "-ve double as double"); + + # -ve Stringized Double + $myobject->ScalarDouble(dbus_double("-2.1")); + is($object->get_last_message_signature, "d", "-ve string as double"); + is($object->get_last_message_param, -2.1, "-ve string as double"); + + # -ve Integer -> double conversion + $myobject->ScalarDouble(dbus_double(-2)); + is($object->get_last_message_signature, "d", "-ve int as double"); + is($object->get_last_message_param, -2.0, "-ve int as double"); + + + #### Byte tests + + # Int + $myobject->ScalarByte(dbus_byte(7)); + is($object->get_last_message_signature, "y", "int as byte"); + is($object->get_last_message_param, 7, "int as byte"); + + # Double roudning + $myobject->ScalarByte(dbus_byte(2.6)); + is($object->get_last_message_signature, "y", "double as byte"); + SKIP: { + skip "rounding actually truncates", 1; + is($object->get_last_message_param, 3, "double as byte"); + } + + # Range overflow + $myobject->ScalarByte(dbus_byte(10000)); + is($object->get_last_message_signature, "y", "int as byte overflow"); + SKIP: { + skip "rounding actually truncates", 1; + is($object->get_last_message_param, 10000, "int as byte overflow"); + } + + # -ve Int + $myobject->ScalarByte(dbus_byte(-7)); + is($object->get_last_message_signature, "y", "-ve int as byte"); + SKIP: { + skip "sign truncation broken", 1; + is($object->get_last_message_param, -7, "-ve int as byte"); + } + + # -ve Double roudning + $myobject->ScalarByte(dbus_byte(-2.6)); + is($object->get_last_message_signature, "y", "double as byte"); + SKIP: { + skip "sign truncation broken", 1; + is($object->get_last_message_param, -3, "double as byte"); + } + + # -ve Range overflow + $myobject->ScalarByte(dbus_byte(-10000)); + is($object->get_last_message_signature, "y", "-ve int as byte overflow"); + SKIP: { + skip "sign truncation broken", 1; + is($object->get_last_message_param, -10000, "-ve int as byte overflow"); + } + + ##### Boolean + + # String, O and false + $myobject->ScalarBoolean(dbus_boolean("0")); + is($object->get_last_message_signature, "b", "string as boolean, 0 and false"); + is($object->get_last_message_param, '', "string as boolean, 0 and false"); + + # String, O but true + $myobject->ScalarBoolean(dbus_boolean("0true")); + is($object->get_last_message_signature, "b", "string as boolean, 0 but true"); + is($object->get_last_message_param, '1', "string as boolean, 0 but true"); + + # String, 1 and true + $myobject->ScalarBoolean(dbus_boolean("1true")); + is($object->get_last_message_signature, "b", "string as boolean, 1 and true"); + is($object->get_last_message_param, '1', "string as boolean, 1 and true"); + + # Int true + $myobject->ScalarBoolean(dbus_boolean(1)); + is($object->get_last_message_signature, "b", "int as boolean, true"); + is($object->get_last_message_param, '1', "int as boolean, true"); + + # Int false + $myobject->ScalarBoolean(dbus_boolean(0)); + is($object->get_last_message_signature, "b", "int as boolean, false"); + is($object->get_last_message_param, '', "int as boolean, false"); + + # Undefined and false + $myobject->ScalarBoolean(dbus_boolean(undef)); + is($object->get_last_message_signature, "b", "undefined as boolean, false"); + is($object->get_last_message_param, '', "undefined as boolean, false"); + +} + + + +TEST_INTROSPECT_TYPING: { + my ($bus, $object, $robject, $myobject, $otherobject) = &setup; + + my $ins = Net::DBus::Binding::Introspector->new(); + $ins->add_method("ScalarString", ["string"], [], "org.example.MyObject", {}, []); + $ins->add_method("ScalarInt16", ["int16"], [], "org.example.MyObject", {}, []); + $ins->add_method("ScalarUInt16", ["uint16"], [], "org.example.MyObject", {}, []); + $ins->add_method("ScalarInt32", ["int32"], [], "org.example.MyObject", {}, []); + $ins->add_method("ScalarUInt32", ["uint32"], [], "org.example.MyObject", {}, []); + $ins->add_method("ScalarDouble", ["double"], [], "org.example.MyObject", {}, []); + $ins->add_method("ScalarByte", ["byte"], [], "org.example.MyObject", {}, []); + $ins->add_method("ScalarBoolean", ["bool"], [], "org.example.MyObject", {}, []); + $object->seed_action("org.freedesktop.DBus.Introspectable", "Introspect", + reply => { return => [ $ins->format($object) ] }); + + ##### String tests + + $myobject->ScalarString("Foo"); + is($object->get_last_message_signature, "s", "string as string"); + is($object->get_last_message_param, "Foo", "string as string"); + + $myobject->ScalarString(2); + is($object->get_last_message->get_signature, "s", "int as string"); + is($object->get_last_message_param, "2", "int as string"); + + $myobject->ScalarString(5.234); + is($object->get_last_message->get_signature, "s", "double as string"); + is($object->get_last_message_param, "5.234", "double as string"); + + + #### INT 16 tests + + # Positive integers + $myobject->ScalarInt16("2"); + is($object->get_last_message_signature, "n", "string as int16"); + is($object->get_last_message_param, 2, "string as int16"); + + $myobject->ScalarInt16(2); + is($object->get_last_message_signature, "n", "int as int16"); + is($object->get_last_message_param, 2, "int as int16"); + + $myobject->ScalarInt16(2.0); + is($object->get_last_message_signature, "n", "double as int16"); + is($object->get_last_message_param, 2, "double as int16"); + + # Negative integers + $myobject->ScalarInt16("-2"); + is($object->get_last_message_signature, "n", "-ve string as int16"); + SKIP: { + skip "sign truncation not checked", 1; + is($object->get_last_message_param, "-2", "-ve string as int16"); + } + + $myobject->ScalarInt16(-2); + is($object->get_last_message_signature, "n", "-ve int as int16"); + SKIP: { + skip "sign truncation not checked", 1; + is($object->get_last_message_param, "-2", "-ve int as int16"); + } + + $myobject->ScalarInt16(-2.0); + is($object->get_last_message_signature, "n", "-ve double as int16"); + SKIP: { + skip "sign truncation not checked", 1; + is($object->get_last_message_param, "-2.0", "-ve double as int16"); + } + + # Rounding of doubles + $myobject->ScalarInt16(2.1); + is($object->get_last_message_signature, "n", "round down double as int16"); + is($object->get_last_message_param, 2, "round down double as int16"); + + $myobject->ScalarInt16(2.9); + is($object->get_last_message_signature, "n", "round up double as int16"); + SKIP: { + skip "double -> int rounding actually truncates", 1; + is($object->get_last_message_param, 3, "round up double as int16"); + } + + $myobject->ScalarInt16(2.5); + is($object->get_last_message_signature, "n", "round up double threshold as int16"); + SKIP: { + skip "double -> int rounding actually truncates", 1; + is($object->get_last_message_param, 3, "round up double threshold as int16"); + } + + $myobject->ScalarInt16(-2.1); + is($object->get_last_message_signature, "n", "-ve round up double as int16"); + is($object->get_last_message_param, -2, "-ve round up double as int16"); + + $myobject->ScalarInt16(-2.9); + is($object->get_last_message_signature, "n", "-ve round down double as int16"); + SKIP: { + skip "double -> int rounding actually truncates", 1; + is($object->get_last_message_param, -3, "-ve round down double as int16"); + } + + $myobject->ScalarInt16(-2.5); + is($object->get_last_message_signature, "n", "-ve round down double threshold as int16"); + is($object->get_last_message_param, -2, "-ve round down double threshold as int16"); + + + #### UINT 16 tests + + # Positive integers + $myobject->ScalarUInt16("2"); + is($object->get_last_message_signature, "q", "string as uint16"); + is($object->get_last_message_param, 2, "string as uint16"); + + $myobject->ScalarUInt16(2); + is($object->get_last_message_signature, "q", "int as uint16"); + is($object->get_last_message_param, 2, "int as uint16"); + + $myobject->ScalarUInt16(2.0); + is($object->get_last_message_signature, "q", "double as uint16"); + is($object->get_last_message_param, 2, "double as uint16"); + + # Negative integers + $myobject->ScalarUInt16("-2"); + is($object->get_last_message_signature, "q", "-ve string as uint16"); + SKIP: { + skip "sign truncation not checked", 1; + is($object->get_last_message_param, -2, "-ve string as uint16"); + } + + $myobject->ScalarUInt16(-2); + is($object->get_last_message_signature, "q", "-ve int as uint16"); + SKIP: { + skip "sign truncation not checked", 1; + is($object->get_last_message_param, -2, "-ve int as uint16"); + } + + $myobject->ScalarUInt16(-2.0); + is($object->get_last_message_signature, "q", "-ve double as uint16"); + SKIP: { + skip "sign truncation not checked", 1; + is($object->get_last_message_param, -2, "-ve double as uint16"); + } + + + # Rounding of doubles + $myobject->ScalarUInt16(2.1); + is($object->get_last_message_signature, "q", "round down double as uint16"); + is($object->get_last_message_param, 2, "round down double as uint16"); + + $myobject->ScalarUInt16(2.9); + is($object->get_last_message_signature, "q", "round up double as uint16"); + SKIP: { + skip "double -> int rounding actually truncates", 1; + is($object->get_last_message_param, 3, "round up double as uint16"); + } + + $myobject->ScalarUInt16(2.5); + is($object->get_last_message_signature, "q", "round up double threshold as uint16"); + SKIP: { + skip "double -> int rounding actually truncates", 1; + is($object->get_last_message_param, 3, "round up double threshold as uint16"); + } + + #### INT 32 tests + + # Positive integers + $myobject->ScalarInt32("2"); + is($object->get_last_message_signature, "i", "string as int32"); + is($object->get_last_message_param, 2, "string as int32"); + + $myobject->ScalarInt32(2); + is($object->get_last_message_signature, "i", "int as int32"); + is($object->get_last_message_param, 2, "int as int32"); + + $myobject->ScalarInt32(2.0); + is($object->get_last_message_signature, "i", "double as int32"); + is($object->get_last_message_param, 2, "double as int32"); + + # Negative integers + $myobject->ScalarInt32("-2"); + is($object->get_last_message_signature, "i", "-ve string as int32"); + SKIP: { + skip "sign truncation not checked", 1; + is($object->get_last_message_param, "-2", "-ve string as int32"); + } + + $myobject->ScalarInt32(-2); + is($object->get_last_message_signature, "i", "-ve int as int32"); + SKIP: { + skip "sign truncation not checked", 1; + is($object->get_last_message_param, "-2", "-ve int as int32"); + } + + $myobject->ScalarInt32(-2.0); + is($object->get_last_message_signature, "i", "-ve double as int32"); + SKIP: { + skip "sign truncation not checked", 1; + is($object->get_last_message_param, "-2.0", "-ve double as int32"); + } + + # Rounding of doubles + $myobject->ScalarInt32(2.1); + is($object->get_last_message_signature, "i", "round down double as int32"); + is($object->get_last_message_param, 2, "round down double as int32"); + + $myobject->ScalarInt32(2.9); + is($object->get_last_message_signature, "i", "round up double as int32"); + SKIP: { + skip "double -> int rounding actually truncates", 1; + is($object->get_last_message_param, 3, "round up double as int32"); + } + + $myobject->ScalarInt32(2.5); + is($object->get_last_message_signature, "i", "round up double threshold as int32"); + SKIP: { + skip "double -> int rounding actually truncates", 1; + is($object->get_last_message_param, 3, "round up double threshold as int32"); + } + + $myobject->ScalarInt32(-2.1); + is($object->get_last_message_signature, "i", "-ve round up double as int32"); + is($object->get_last_message_param, -2, "-ve round up double as int32"); + + $myobject->ScalarInt32(-2.9); + is($object->get_last_message_signature, "i", "-ve round down double as int32"); + SKIP: { + skip "double -> int rounding actually truncates", 1; + is($object->get_last_message_param, -3, "-ve round down double as int32"); + } + + $myobject->ScalarInt32(-2.5); + is($object->get_last_message_signature, "i", "-ve round down double threshold as int32"); + is($object->get_last_message_param, -2, "-ve round down double threshold as int32"); + + + #### UINT 32 tests + + # Positive integers + $myobject->ScalarUInt32("2"); + is($object->get_last_message_signature, "u", "string as uint32"); + is($object->get_last_message_param, 2, "string as uint32"); + + $myobject->ScalarUInt32(2); + is($object->get_last_message_signature, "u", "int as uint32"); + is($object->get_last_message_param, 2, "int as uint32"); + + $myobject->ScalarUInt32(2.0); + is($object->get_last_message_signature, "u", "double as uint32"); + is($object->get_last_message_param, 2, "double as uint32"); + + # Negative integers + $myobject->ScalarUInt32("-2"); + is($object->get_last_message_signature, "u", "-ve string as uint32"); + SKIP: { + skip "sign truncation not checked", 1; + is($object->get_last_message_param, -2, "-ve string as uint32"); + } + + $myobject->ScalarUInt32(-2); + is($object->get_last_message_signature, "u", "-ve int as uint32"); + SKIP: { + skip "sign truncation not checked", 1; + is($object->get_last_message_param, -2, "-ve int as uint32"); + } + + $myobject->ScalarUInt32(-2.0); + is($object->get_last_message_signature, "u", "-ve double as uint32"); + SKIP: { + skip "sign truncation not checked", 1; + is($object->get_last_message_param, -2, "-ve double as uint32"); + } + + + # Rounding of doubles + $myobject->ScalarUInt32(2.1); + is($object->get_last_message_signature, "u", "round down double as uint32"); + is($object->get_last_message_param, 2, "round down double as uint32"); + + $myobject->ScalarUInt32(2.9); + is($object->get_last_message_signature, "u", "round up double as uint32"); + SKIP: { + skip "double -> int rounding actually truncates", 1; + is($object->get_last_message_param, 3, "round up double as uint32"); + } + + $myobject->ScalarUInt32(2.5); + is($object->get_last_message_signature, "u", "round up double threshold as uint32"); + SKIP: { + skip "double -> int rounding actually truncates", 1; + is($object->get_last_message_param, 3, "round up double threshold as uint32"); + } + + #### Double tests + + # Double + $myobject->ScalarDouble(5.234); + is($object->get_last_message_signature, "d", "double as double"); + is($object->get_last_message_param, 5.234, "double as double"); + + # Stringized Double + $myobject->ScalarDouble("2.1"); + is($object->get_last_message_signature, "d", "string as double"); + is($object->get_last_message_param, 2.1, "string as double"); + + # Integer -> double conversion + $myobject->ScalarDouble(2); + is($object->get_last_message_signature, "d", "int as double"); + is($object->get_last_message_param, 2.0, "int as double"); + + + # -ve Double + $myobject->ScalarDouble(-5.234); + is($object->get_last_message_signature, "d", "-ve double as double"); + is($object->get_last_message_param, -5.234, "-ve double as double"); + + # -ve Stringized Double + $myobject->ScalarDouble("-2.1"); + is($object->get_last_message_signature, "d", "-ve string as double"); + is($object->get_last_message_param, -2.1, "-ve string as double"); + + # -ve Integer -> double conversion + $myobject->ScalarDouble(-2); + is($object->get_last_message_signature, "d", "-ve int as double"); + is($object->get_last_message_param, -2.0, "-ve int as double"); + + + #### Byte tests + + # Int + $myobject->ScalarByte(7); + is($object->get_last_message_signature, "y", "int as byte"); + is($object->get_last_message_param, 7, "int as byte"); + + # Double roudning + $myobject->ScalarByte(2.6); + is($object->get_last_message_signature, "y", "double as byte"); + SKIP: { + skip "double rounding not sorted", 1; + is($object->get_last_message_param, 3, "double as byte"); + } + + # Range overflow + $myobject->ScalarByte(10000); + is($object->get_last_message_signature, "y", "int as byte overflow"); + SKIP: { + skip "byte overflow not checked", 1; + is($object->get_last_message_param, 2, "int as byte overflow"); + } + + + # -ve Int + $myobject->ScalarByte(-7); + is($object->get_last_message_signature, "y", "-ve int as byte"); + SKIP: { + skip "byte sign truncation not double checked", 1; + is($object->get_last_message_param, 2, "-ve int as byte"); + } + + # -ve Double roudning + $myobject->ScalarByte(-2.6); + is($object->get_last_message_signature, "y", "double as byte"); + SKIP: { + skip "byte sign truncation not double checked", 1; + is($object->get_last_message_param, 2, "-ve double as byte"); + } + + # -ve Range overflow + $myobject->ScalarByte(-10000); + is($object->get_last_message_signature, "y", "-ve int as byte overflow"); + SKIP: { + skip "byte sign truncation not double checked", 1; + is($object->get_last_message_param, 2, "-ve int as byte overflow"); + } + + ##### Boolean + + # String, O and false + $myobject->ScalarBoolean("0"); + is($object->get_last_message_signature, "b", "string as boolean, 0 and false"); + is($object->get_last_message_param, '', "string as boolean, 0 and false"); + + # String, O but true + $myobject->ScalarBoolean("0true"); + is($object->get_last_message_signature, "b", "string as boolean, 0 but true"); + is($object->get_last_message_param, 1, "string as boolean, 0 but true"); + + # String, 1 and true + $myobject->ScalarBoolean("1true"); + is($object->get_last_message_signature, "b", "string as boolean, 1 and true"); + is($object->get_last_message_param, 1, "string as boolean, 1 and true"); + + # Int true + $myobject->ScalarBoolean(1); + is($object->get_last_message_signature, "b", "int as boolean, true"); + is($object->get_last_message_param, 1, "int as boolean, true"); + + # Int false + $myobject->ScalarBoolean(0); + is($object->get_last_message_signature, "b", "int as boolean, false"); + is($object->get_last_message_param, '', "int as boolean, false"); + + # Undefined and false + $myobject->ScalarBoolean(undef); + is($object->get_last_message_signature, "b", "undefined as boolean, false"); + is($object->get_last_message_param, '', "undefined as boolean, false"); + +} + +exit 0; + +sub setup { + my $bus = Net::DBus->test; + my $service = $bus->export_service("org.cpan.Net.Bus.test"); + + my $object = Net::DBus::Test::MockObject->new($service, "/org/example/MyObject"); + + my $rservice = $bus->get_service("org.cpan.Net.Bus.test"); + my $robject = $rservice->get_object("/org/example/MyObject"); + my $myobject = $robject->as_interface("org.example.MyObject"); + my $otherobject = $robject->as_interface("org.example.OtherObject"); + + $object->seed_action("org.example.MyObject", "ScalarString", reply => { return => [] }); + $object->seed_action("org.example.MyObject", "ScalarInt16", reply => { return => [] }); + $object->seed_action("org.example.MyObject", "ScalarUInt16", reply => { return => [] }); + $object->seed_action("org.example.MyObject", "ScalarInt32", reply => { return => [] }); + $object->seed_action("org.example.MyObject", "ScalarUInt32", reply => { return => [] }); + $object->seed_action("org.example.MyObject", "ScalarDouble", reply => { return => [] }); + $object->seed_action("org.example.MyObject", "ScalarByte", reply => { return => [] }); + $object->seed_action("org.example.MyObject", "ScalarBoolean", reply => { return => [] }); + + + return ($bus, $object, $robject, $myobject, $otherobject); +} + diff --git a/t/60-object-props.t b/t/60-object-props.t new file mode 100644 index 0000000..c0467c4 --- /dev/null +++ b/t/60-object-props.t @@ -0,0 +1,295 @@ +# -*- perl -*- +use Test::More tests => 18; + +use strict; +use warnings; + +BEGIN { + use_ok('Net::DBus::Binding::Introspector'); + use_ok('Net::DBus::Object'); +}; + +package MyObject; + +use base qw(Net::DBus::Object); +use Net::DBus::Exporter qw(org.example.MyObject); + +# Typically one would use Class::MethodMaker, but I don't +# want to add a hard dependancy for the test suite. +#use Class::MethodMaker [ scalar => ["name", "email", "age" ]]; + +sub name { + my $self = shift; + $self->{name} = shift if @_; + return $self->{name}; +} + +sub email { + my $self = shift; + $self->{email} = shift if @_; + return $self->{email}; +} + +sub age { + my $self = shift; + $self->{age} = shift if @_; + return $self->{age}; +} + +sub parents { + my $self = shift; + $self->{parents} = shift if @_; + return $self->{parents}; +} + +sub height { + my $self = shift; + $self->{height} = shift if @_; + return $self->{height}; +} + +dbus_property("name", "string"); +dbus_property("email", "string", "read"); +dbus_property("age", "int32" ,"write"); +dbus_property("parents", ["array", "string"]); +dbus_property("height", "double", "write"); + +package main; + +use Net::DBus qw(:typing); +my $bus = Net::DBus->test; +my $service = $bus->export_service("org.cpan.Net.Bus.test"); +my $object = MyObject->new($service, "/org/example/MyObject"); + +my $introspector = $object->_introspector; + +my $xml_got = $introspector->format($object); + +my $xml_expect = < + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +EOF + +is($xml_got, $xml_expect, "xml data matches"); + +GET_NAME: { + my $msg = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", + object_path => "/org/example/MyObject", + interface => "org.freedesktop.DBus.Properties", + method_name => "Get"); + + my $iter = $msg->iterator(1); + $iter->append_string("org.example.MyObject"); + $iter->append_string("name"); + + $object->name("John Doe"); + + my $reply = $bus->get_connection->send_with_reply_and_block($msg); + + is($reply->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); + + my ($value) = $reply->get_args_list; + is($value, "John Doe", "name is John Doe"); +} + +GET_BOGUS: { + my $msg = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", + object_path => "/org/example/MyObject", + interface => "org.freedesktop.DBus.Properties", + method_name => "Get"); + + my $iter = $msg->iterator(1); + $iter->append_string("org.example.MyObject"); + $iter->append_string("bogus"); + + $object->name("John Doe"); + + my $reply = eval { + $bus->get_connection->send_with_reply_and_block($msg); + }; + ok($@, "error is set"); +} + +sub GET_SET_NAME: { + my $msg1 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", + object_path => "/org/example/MyObject", + interface => "org.freedesktop.DBus.Properties", + method_name => "Get"); + + my $iter1 = $msg1->iterator(1); + $iter1->append_string("org.example.MyObject"); + $iter1->append_string("name"); + + $object->name("John Doe"); + + my $reply1 = $bus->get_connection->send_with_reply_and_block($msg1); + + is($reply1->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); + + my ($value1) = $reply1->get_args_list; + is($value1, "John Doe", "name is John Doe"); + + + my $msg2 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", + object_path => "/org/example/MyObject", + interface => "org.freedesktop.DBus.Properties", + method_name => "Set"); + + my $iter2 = $msg2->iterator(1); + $iter2->append_string("org.example.MyObject"); + $iter2->append_string("name"); + $iter2->append_variant("Jane Doe"); + + my $reply2 = $bus->get_connection->send_with_reply_and_block($msg2); + + is($reply2->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); + + + my $reply3 = $bus->get_connection->send_with_reply_and_block($msg1); + + is($reply3->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); + + my ($value2) = $reply3->get_args_list; + is($value2, "Jane Doe", "name is Jane Doe"); +} + + +SET_AGE: { + my $msg1 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", + object_path => "/org/example/MyObject", + interface => "org.freedesktop.DBus.Properties", + method_name => "Get"); + + my $iter1 = $msg1->iterator(1); + $iter1->append_string("org.example.MyObject"); + $iter1->append_string("age"); + + + my $msg2 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", + object_path => "/org/example/MyObject", + interface => "org.freedesktop.DBus.Properties", + method_name => "Set"); + + my $iter2 = $msg2->iterator(1); + $iter2->append_string("org.example.MyObject"); + $iter2->append_string("age"); + $iter2->append_variant(21); + + my $reply1 = $bus->get_connection->send_with_reply_and_block($msg2); + + is($reply1->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); + + + my $reply2 = eval { + $bus->get_connection->send_with_reply_and_block($msg1); + }; + ok($@, "error is set"); + + is($object->age, 21, "age is 21"); +} + + +GET_EMAIL: { + my $msg1 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", + object_path => "/org/example/MyObject", + interface => "org.freedesktop.DBus.Properties", + method_name => "Get"); + + my $iter1 = $msg1->iterator(1); + $iter1->append_string("org.example.MyObject"); + $iter1->append_string("email"); + + $object->email('john@example.com'); + + my $msg2 = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", + object_path => "/org/example/MyObject", + interface => "org.freedesktop.DBus.Properties", + method_name => "Set"); + + my $iter2 = $msg2->iterator(1); + $iter2->append_string("org.example.MyObject"); + $iter2->append_string("email"); + $iter2->append_variant('jane@example.com'); + + my $reply1 = eval { + $bus->get_connection->send_with_reply_and_block($msg2); + }; + ok($@, "error is set"); + + my $reply2 = $bus->get_connection->send_with_reply_and_block($msg1); + + is($reply2->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); + + is($object->age, 21, "age is 21"); + + my ($value) = $reply2->get_args_list; + is($value, 'john@example.com', 'email is john@example.com'); +} + + +SET_HEIGHT: { + my $msg = $bus->get_connection()->make_method_call_message("org.example.MyService", + "/org/example/MyObject", + "org.freedesktop.DBus.Properties", + "Set"); + + $introspector->encode($msg, "methods", "Set", "params", "org.example.MyObject", "height", dbus_double(1.414)); + + is($msg->get_signature, "ssv", "signature is ssvd"); + + my $reply = $bus->get_connection->send_with_reply_and_block($msg); + + is($reply->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); + + ok($object->height > 1.410 && + $object->height < 1.420, "height is 1.414"); +} + +GET_ALL: { + my $msg = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", + object_path => "/org/example/MyObject", + interface => "org.freedesktop.DBus.Properties", + method_name => "GetAll"); + + my $iter = $msg->iterator(1); + $iter->append_string("org.example.MyObject"); + $iter->append_string("name"); + + my $reply = $bus->get_connection->send_with_reply_and_block($msg); + + is($reply->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); + + my ($value) = $reply->get_args_list; + # we use sort because there is no strict order of keys(...) call result + is_deeply([sort(keys(%$value))], [sort("name", "email", "parents")], "all readable properties have been received"); +} diff --git a/t/65-object-magic.t b/t/65-object-magic.t new file mode 100644 index 0000000..21e7c33 --- /dev/null +++ b/t/65-object-magic.t @@ -0,0 +1,182 @@ +# -*- perl -*- +use Test::More tests => 13; + +use strict; +use warnings; + +BEGIN { + use_ok('Net::DBus::Binding::Introspector'); + use_ok('Net::DBus::Object'); +}; + +package MyObject; + +use base qw(Net::DBus::Object); +use Net::DBus::Exporter qw(org.example.MyObject); + +dbus_method("test_set_serial", ["serial"]); +sub test_set_serial { + my $self = shift; + my @args = @_; + $self->{lastargs} = \@args; +} + +dbus_method("test_set_caller", ["caller"]); +sub test_set_caller { + my $self = shift; + my @args = @_; + $self->{lastargs} = \@args; +} + +dbus_method("test_set_multi_args1", ["string", "caller"]); +sub test_set_multi_args1 { + my $self = shift; + my @args = @_; + $self->{lastargs} = \@args; +} + +dbus_method("test_set_multi_args2", ["caller", "string"]); +sub test_set_multi_args2 { + my $self = shift; + my @args = @_; + $self->{lastargs} = \@args; +} + +dbus_method("test_set_multi_args3", ["string", "caller", "string"]); +sub test_set_multi_args3 { + my $self = shift; + my @args = @_; + $self->{lastargs} = \@args; +} + +package main; + +my $bus = Net::DBus->test; +my $service = $bus->export_service("/org/cpan/Net/Bus/test"); +my $object = MyObject->new($service, "/org/example/MyObject"); + +my $introspector = $object->_introspector; + +my $xml_got = $introspector->format($object); + +my $xml_expect = < + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +EOF + +is($xml_got, $xml_expect, "xml data matches"); + +CALLER: { + my $msg = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", + object_path => "/org/example/MyObject", + interface => "org.example.MyObject", + method_name => "test_set_caller"); + $msg->set_sender(":1.1"); + + my $reply = $bus->get_connection->send_with_reply_and_block($msg); + is($reply->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); + + is_deeply($object->{lastargs}, [":1.1"], "caller is :1.1"); +} + + +SERIAL: { + my $msg = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", + object_path => "/org/example/MyObject", + interface => "org.example.MyObject", + method_name => "test_set_serial"); + + my $reply = $bus->get_connection->send_with_reply_and_block($msg); + + is($reply->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); + + is_deeply($object->{lastargs}, [$msg->get_serial], "serial matches"); +} + +MULTI_ARGS1: { + my $msg = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", + object_path => "/org/example/MyObject", + interface => "org.example.MyObject", + method_name => "test_set_multi_args1"); + $msg->set_sender(":1.1"); + my $iter = $msg->iterator(1); + $iter->append_string("one"); + + my $reply = $bus->get_connection->send_with_reply_and_block($msg); + + is($reply->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); + + is_deeply($object->{lastargs}, ["one",":1.1"], "caller matches"); +} + +MULTI_ARGS2: { + my $msg = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", + object_path => "/org/example/MyObject", + interface => "org.example.MyObject", + method_name => "test_set_multi_args2"); + $msg->set_sender(":1.1"); + my $iter = $msg->iterator(1); + $iter->append_string("one"); + + my $reply = $bus->get_connection->send_with_reply_and_block($msg); + + is($reply->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); + + is_deeply($object->{lastargs}, [":1.1", "one"], "caller matches"); +} + +MULTI_ARGS3: { + my $msg = Net::DBus::Binding::Message::MethodCall->new(service_name => "org.example.MyService", + object_path => "/org/example/MyObject", + interface => "org.example.MyObject", + method_name => "test_set_multi_args3"); + $msg->set_sender(":1.1"); + my $iter = $msg->iterator(1); + $iter->append_string("one"); + $iter->append_string("two"); + + my $reply = $bus->get_connection->send_with_reply_and_block($msg); + + is($reply->get_type, &Net::DBus::Binding::Message::MESSAGE_TYPE_METHOD_RETURN); + + is_deeply($object->{lastargs}, ["one",":1.1", "two"], "caller matches"); +} diff --git a/t/66-child-objects.t b/t/66-child-objects.t new file mode 100644 index 0000000..1fdc217 --- /dev/null +++ b/t/66-child-objects.t @@ -0,0 +1,196 @@ +# -*- perl -*- +use Test::More tests => 5; + +use strict; +use warnings; + +BEGIN { + use_ok('Net::DBus::Binding::Introspector'); + use_ok('Net::DBus::Object'); +}; + +package ObjectType1; + +use base qw(Net::DBus::Object); +use Net::DBus::Exporter qw(com.dbelser.test.type1); + +sub new { + my $class = shift; + my $service = shift; + my $path = shift; + my $name = shift; + + my $self = $class->SUPER::new($service, "$path"); + bless $self, $class; + + $self->{name} = $name; + return $self; +} + +dbus_method("version", [], ["string"], { arg_names=>["version"],} ); +sub version { + my $self = shift; + return ("$self->{name}: ObjectType1, Version 0.1"); +} + + +package ObjectType2; + +use base qw(Net::DBus::Object); +use Net::DBus::Exporter qw(com.dbelser.test.type2); + +sub new { + my $class = shift; + my $service = shift; + my $path = shift; + my $name = shift; + + my $self = $class->SUPER::new($service, "$path"); + bless $self, $class; + $self->{name} = $name; + + return $self; +} + +dbus_method("version", [], ["string"], { arg_names=>["version"],} ); +sub version { + my $self = shift; + return ("$self->{name}: ObjectType2, Version 0.1"); +} + + +package ObjectType3; + +use base qw(Net::DBus::Object); +use Net::DBus::Exporter qw(com.dbelser.test.type3); + +sub new { + my $class = shift; + my $service = shift; + my $path = shift; + my $name = shift; + + my $self = $class->SUPER::new($service, "$path"); + bless $self, $class; + $self->{name} = $name; + + return $self; +} + +dbus_method("version", [], ["string"], { arg_names=>["version"],} ); +sub version { + my $self = shift; + return ("$self->{name}: ObjectType3, Version 0.1"); +} + + +package main; + +use Net::DBus qw(:typing); +my $bus = Net::DBus->test; +my $service = $bus->export_service("org.cpan.Net.Bus.test"); + +# base path for this app +my $base = "/base"; + +my $root = ObjectType1->new($service,$base,"Root"); + +# second tier one each +my $c1 = ObjectType1->new($root,"/branch_1", "C1"); +my $c2 = ObjectType2->new($root,"/branch_2", "C2"); +my $c3 = ObjectType3->new($root,"/branch_3", "C3"); + +# go deep +my $c4 = ObjectType1->new($c1,"/one", "C4"); +my $c5 = ObjectType2->new($c4,"/two", "C5"); +my $c6 = ObjectType3->new($c5,"/three", "C6"); + +# skip some nodes +my $c7 = ObjectType1->new($c2,"/skip/one", "C7"); +my $c8 = ObjectType2->new($c7,"/skip/skip/two", "C8"); +my $c9 = ObjectType3->new($c8,"/skip/skip/skip/three", "C9"); + +my $introspector = $root->_introspector; +my $xml_got = $introspector->format($root); + +my $xml_expect = < + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +EOF + +is($xml_got, $xml_expect, "xml data matches"); + +my $ins2 = Net::DBus::Binding::Introspector->new(xml => $xml_got); + +my @children = $ins2->list_children(); +is_deeply(\@children, ["/branch_1", "/branch_2", "/branch_3"], "children match"); + + +$introspector = $c2->_introspector; +$xml_got = $introspector->format($c2); + +$xml_expect = < + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +EOF +is($xml_got, $xml_expect, "xml data matches"); diff --git a/t/70-errors.t b/t/70-errors.t new file mode 100644 index 0000000..466125a --- /dev/null +++ b/t/70-errors.t @@ -0,0 +1,57 @@ +# -*- perl -*- +use Test::More tests => 6; + +use strict; +use warnings; + +BEGIN { + use_ok('Net::DBus'); + use_ok('Net::DBus::Error'); + use_ok('Net::DBus::Object'); +}; + +package MyError; + +use base qw(Net::DBus::Error); + +sub new { + my $proto = shift; + my $class = ref($proto) || $proto; + my $self = $class->SUPER::new(name => "org.example.music.UnknownFormat", + message => "Unknown track encoding format"); +} + + +package MyObject; + +use base qw(Net::DBus::Object); +use Net::DBus::Exporter qw(org.example.MyObject); + +dbus_method("play", ["string"], ["string"]); +sub play { + my $self = shift; + my $url = shift; + + if ($url =~ /\.(mp3|ogg)$/) { + return $url; + } else { + die MyError->new(); + } +} + +package main; + +my $bus = Net::DBus->test; +my $service = $bus->export_service("org.cpan.Net.Bus.test"); +my $object = MyObject->new($service, "/org/example/MyObject"); + +my $rservice = $bus->get_service("org.cpan.Net.Bus.test"); +my $robject = $rservice->get_object("/org/example/MyObject"); + +eval { + $robject->play("foo.flac"); +}; +my $error = $@; +isa_ok($error, "Net::DBus::Error"); +is($error->name, "org.example.music.UnknownFormat", "error name is set"); +is($error->message, "Unknown track encoding format", "error description is set"); diff --git a/t/75-notifications.t b/t/75-notifications.t new file mode 100644 index 0000000..7bf79b0 --- /dev/null +++ b/t/75-notifications.t @@ -0,0 +1,71 @@ +# -*- perl -*- +use Test::More tests => 10; + +# This test case is primarily about variants - but +# in particular the signature of org.freedesktop.Notifications.Notify + +use strict; +use warnings; + +BEGIN { + use_ok('Net::DBus') or die; + use_ok('Net::DBus::Object') or die; +}; + + +package MyObject; + +use base qw(Net::DBus::Object); +use Net::DBus::Exporter qw(org.cpan.Net.DBus.Test.Notify); + +sub new { + my $class = shift; + my $service = shift; + my $self = $class->SUPER::new($service, "/org/cpan/Net/DBus/Test/Notify"); + + bless $self, $class; + + $self->{data} = {}; + + return $self; +} + +dbus_method("Notify", ["string", "uint32", "string", "string", "string", ["array", "string"], [ "dict", "string", ["variant"]], "int32"],["uint32"]); +sub Notify { + my $self = shift; + + $self->{data} = \@_; + + return 0; +} + +package main; + +my $bus = Net::DBus->test; + +my $svc = $bus->export_service("org.cpan.Net.DBus.Test.Notify"); +my $obj = MyObject->new($svc); + +my $rsvc = $bus->get_service("org.cpan.Net.DBus.Test.Notify"); +my $robj = $rsvc->get_object("/org/cpan/Net/DBus/Test/Notify"); + +my $res = $robj->Notify( + "dbus-test", # Application name + 7, # replaces_id (0 -> nothing) + 'someicon', #app_icon ("" -> no icon) + 'Test event', # summary + "This is a test to see if DBUS works nicely in Perl.\nI hope that this works.", # body + ["frob", "wibble"], # actions + {"ooh" => "eek", "bar" => "wizz"}, # hints + 2_000 # expire_timeout in milliseconds + ); + +is($obj->{data}->[0], "dbus-test", "name is correct"); +is($obj->{data}->[1], 7, "replacesid is correct"); +is($obj->{data}->[2], "someicon", "icon is correct"); +is($obj->{data}->[3], "Test event", "summary is correct"); +is($obj->{data}->[4], "This is a test to see if DBUS works nicely in Perl.\nI hope that this works.", "name is correct"); +is_deeply($obj->{data}->[5], ["frob", "wibble"], "actions is correct"); +is_deeply($obj->{data}->[6], {"ooh" => "eek", "bar" => "wizz"}, "hints is correct"); +is($obj->{data}->[7], 2_000, "timeout is correct"); + diff --git a/typemap b/typemap new file mode 100644 index 0000000..b43477f --- /dev/null +++ b/typemap @@ -0,0 +1,125 @@ +TYPEMAP +const char * T_PV +DBusConnection* O_OBJECT_connection +DBusServer* O_OBJECT_server +DBusMessage* O_OBJECT_message +DBusPendingCall* O_OBJECT_pendingcall +DBusWatch* O_OBJECT_watch +DBusTimeout* O_OBJECT_timeout +DBusMessageIter* O_OBJECT_messageiter +DBusBusType T_IV +dbus_bool_t T_BOOL +dbus_int16_t T_IV +dbus_uint16_t T_UV +dbus_int32_t T_IV +dbus_uint32_t T_UV +dbus_int64_t T_DBUS_INT64 +dbus_uint64_t T_DBUS_UINT64 + +INPUT +T_DBUS_INT64 + $var = _dbus_parse_int64($arg); + +OUTPUT +T_DBUS_INT64 + $arg = _dbus_format_int64($var); + +INPUT +T_DBUS_UINT64 + $var = _dbus_parse_uint64($arg); + +OUTPUT +T_DBUS_UINT64 + $arg = _dbus_format_uint64($var); + +INPUT +O_OBJECT_connection + 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_connection + sv_setref_pv( $arg, "Net::DBus::Binding::C::Connection", (void*)$var ); + +INPUT +O_OBJECT_server + 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_server + sv_setref_pv( $arg, "Net::DBus::Binding::C::Server", (void*)$var ); + +INPUT +O_OBJECT_message + 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_message + sv_setref_pv( $arg, "Net::DBus::Binding::C::Message", (void*)$var ); + + +INPUT +O_OBJECT_pendingcall + 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_pendingcall + sv_setref_pv( $arg, "Net::DBus::Binding::C::PendingCall", (void*)$var ); + +INPUT +O_OBJECT_watch + 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_watch + sv_setref_pv( $arg, "Net::DBus::Binding::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, "Net::DBus::Binding::C::Timeout", (void*)$var ); + +INPUT +O_OBJECT_messageiter + 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_messageiter + sv_setref_pv( $arg, "Net::DBus::Binding::Iterator", (void*)$var );