--- /dev/null
+ Net::DBus - Perl APIs for DBus
+ ==============================
+
+Net::DBus is written by
+
+ Daniel Berrange <dan-at-berrange-dot-com>
+
+With patches, contributions & suggestions gratefully received
+from
+
+ Carlos Garnacho <carlosg-at-gnome-dot-org>
+ Emmanuele Bassi <ebassi-at-gmail-dot-com>
+ Olivier Blin <oblin-at-mandriva-dot-com>
+ Jack <ms419-at-freezone-dot-co-dot-uk>
+ Dave Belser <dbelser-at-aerosat-dot-com>
+ Stefan Pfetzing <dreamind@dreamind.de>
+ Pavel Strashkin <pavel.strashkin@gmail.com>
+ Mathieu Bridon <bochecha@fedoraproject.org>
+
+ [...send patches to get your name here!]
+
+-- End
--- /dev/null
+
+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
--- /dev/null
+/* -*- 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 <dbus/dbus.h>
+
+#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
--- /dev/null
+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.
+\f
+ 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.)
+\f
+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.
+\f
+ 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
--- /dev/null
+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
--- /dev/null
+pm_to_blib
+DBus\.o
+DBus\.c
+DBus\.bs
+.*.old
+DBus-
+blib
+.*\.bak
+CVS
+.cvsignore
+.*~
+.#.*
+#.*
+.hg
+^Makefile$
+^cover_db/
+Net-DBus-.*.tar.gz
--- /dev/null
+--- #YAML:1.0
+name: Net-DBus
+abstract: Extension for the DBus bindings
+version: 1.0.0
+author:
+ - Daniel P. Berrange <dan@berrange.com>
+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
--- /dev/null
+# Copyright (C) 2008 Daniel Berrange <dan@berrange.com>
+
+use strict;
+use warnings;
+
+die unless (scalar @ARGV == 1);
+
+open SRC, "lib/Net/DBus.pm"
+ or die "lib/Net/DBus.pm: $!";
+
+our $VERSION;
+while (<SRC>) {
+ if (/\$VERSION\s*=\s*'(.*)'/) {
+ $VERSION=$1;
+ }
+}
+close SRC;
+
+local $/ = undef;
+$_ = <DATA>;
+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 <dan@berrange.com>
+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
--- /dev/null
+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 <dan@berrange.com>',
+ '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__
--- /dev/null
+# 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
--- /dev/null
+# -*- rpm-spec -*-
+# Copyright (C) 2004-2006 Daniel Berrange <dan@berrange.com>
+#
+# $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 (<SRC>) {
+ if (/\$VERSION\s*=\s*'(.*)'/) {
+ $VERSION=$1;
+ }
+}
+close SRC;
+
+local $/ = undef;
+$_ = <DATA>;
+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
--- /dev/null
+ 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<pkg-config> 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 <dan at berrange dot com>
+
+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
+
--- /dev/null
+#!/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
+
--- /dev/null
+#!/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";
+
+
--- /dev/null
+#!/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);
+}
+
--- /dev/null
+#/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;
--- /dev/null
+#/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";
--- /dev/null
+#/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";
+
+}
--- /dev/null
+#!/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();
--- /dev/null
+#!/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();
--- /dev/null
+#!/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();
--- /dev/null
+#!/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();
--- /dev/null
+#!/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();
+
+
--- /dev/null
+#!/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();
--- /dev/null
+#!/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";
+}
--- /dev/null
+#!/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);
--- /dev/null
+#!/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();
--- /dev/null
+# -*- 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<Net::DBus::Service> and L<Net::DBus::Object>
+modules are of most relevance, or are client consumers, in which
+case L<Net::DBus::RemoteService> and L<Net::DBus::RemoteObject>
+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<params> hash can contain be used to specify
+connection options. The only support option at this time
+is C<nomainloop> which prevents the bus from being automatically
+attached to the main L<Net::DBus::Reactor> 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<params> hash can contain be used to specify
+connection options. The only support option at this time
+is C<nomainloop> which prevents the bus from being automatically
+attached to the main L<Net::DBus::Reactor> 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<params> hash can contain be used to specify
+connection options. The only support option at this time
+is C<nomainloop> which prevents the bus from being automatically
+attached to the main L<Net::DBus::Reactor> 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<Net::DBus::Test::MockConnection> 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<unix:abstract=/tmp/dbus-PBFyyuUiVb,guid=191e0a43c3efc222e0818be556d67500>,
+while one for a system bus would look like C<unix:/var/run/dbus/system_bus_socket>.
+The optional C<params> hash can contain be used to specify
+connection options. The only support option at this time
+is C<nomainloop> which prevents the bus from being automatically
+attached to the main L<Net::DBus::Reactor> 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<Net::DBus::Binding::Bus> 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<Net::DBus::RemoteService> 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<Net::DBus::Service> 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</org/freedesktop/DBus>,
+provided by the service C<org.freedesktop.DBus>. The returned
+object is an instance of L<Net::DBus::RemoteObject>
+
+=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<Net::DBus>, L<Net::DBus::RemoteService>, L<Net::DBus::Service>,
+L<Net::DBus::RemoteObject>, L<Net::DBus::Object>,
+L<Net::DBus::Exporter>, L<Net::DBus::Dumper>, L<Net::DBus::Reactor>,
+C<dbus-monitor(1)>, C<dbus-daemon-1(1)>, C<dbus-send(1)>, L<http://dbus.freedesktop.org>,
+
+=head1 AUTHOR
+
+Daniel Berrange <dan@berrange.com>
+
+=head1 COPYRIGHT
+
+Copyright 2004-2011 by Daniel Berrange
+
+=cut
+
+1;
--- /dev/null
+# -*- 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<dbus_call_async>
+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<get_result> 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<get_result>
+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<is_ready> 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 <dan@berrange.com>
+
+=head1 COPYRIGHT
+
+Copright (C) 2006-2011, Daniel Berrange.
+
+=head1 SEE ALSO
+
+L<Net::DBus>, L<Net::DBus::RemoteObject>, L<Net::DBus::Annotation>
+
+=cut
--- /dev/null
+# -*- 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 <dan@berrange.com>
+
+=head1 COPYRIGHT
+
+Copright (C) 2006-2011, Daniel Berrange.
+
+=head1 SEE ALSO
+
+L<Net::DBus>, L<Net::DBus::RemoteObject>
+
+=cut
--- /dev/null
+# -*- 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<Net::DBus::Binding::Connection>
+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<session> or
+C<system> methods in L<Net::DBus>.
+
+=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<type> parameter, or an arbitrary bus specified
+using the C<address> parameter. If the C<private> 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<Net::DBus::Binding::Connection>, L<Net::DBus>
+
+=cut
--- /dev/null
+# -*- 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<address>. If the C<private> 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<disconnect>
+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<flush>. This
+method will return the serial number of the message,
+which can be used to identify a subsequent reply (if
+any).
+
+=cut
+
+sub send {
+ my $self = shift;
+ my $msg = shift;
+
+ 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<Net::DBus::Binding::Message::MethodReturn> or C<Net::DBus::Binding::Message::Error>
+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<Net::DBus::Binding::PendingCall> 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<return_message> method, or removed
+permanently with th C<steal_message> method as soon as
+is practical.
+
+=cut
+
+sub borrow_message {
+ my $self = shift;
+
+ my $msg = $self->{connection}->dbus_connection_borrow_message();
+ return $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<Net::DBus::Binding::Reactor> for example), you probably
+don't want to be calling this method.
+
+=cut
+
+sub pop_message {
+ my $self = shift;
+
+ my $msg = $self->{connection}->dbus_connection_pop_message();
+ return $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<Net::DBus::Binding::Reactor> object
+as the application event loop, then the 'manage' method on
+that object will call this on your behalf.
+
+=cut
+
+sub set_watch_callbacks {
+ my $self = shift;
+ my $add = shift;
+ 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<Net::DBus::Binding::Reactor> object
+as the application event loop, then the 'manage' method on
+that object will call this on your behalf.
+
+=cut
+
+sub set_timeout_callbacks {
+ my $self = shift;
+ my $add = shift;
+ my $remove = shift;
+ my $toggled = shift;
+
+ $self->{add_timeout} = $add;
+ $self->{remove_timeout} = $remove;
+ $self->{toggled_timeout} = $toggled;
+
+ $self->{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<Net::DBus::Binding::Message> 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<register_object_path>
+or C<register_fallback> 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<Net::DBus::Binding::Message> 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<Net::DBus::Binding::Message>.
+
+=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<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;
+
+ 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<replyto> 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<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;
+
+ 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<Net::DBus::Binding::Server>, L<Net::DBus::Binding::Bus>, L<Net::DBus::Binding::Message::Signal>, L<Net::DBus::Binding::Message::MethodCall>, L<Net::DBus::Binding::Message::MethodReturn>, L<Net::DBus::Binding::Message::Error>
+
+=cut
--- /dev/null
+# -*- 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<Net::DBus::Exporter>.
+
+=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<object_path> parameter. The optional
+C<xml> 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<read>, C<write>,
+or C<readwrite>. 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<Net::DBus::Object> to include object
+specific information in the XML (eg child nodes).
+
+=cut
+
+sub format {
+ my $self = shift;
+ my $obj = shift;
+
+ my $xml = '<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"' . "\n";
+ $xml .= '"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">' . "\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<format> 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 . '<node name="' . $path . '">' . "\n";
+
+ foreach my $name (sort { $a cmp $b } keys %{$self->{interfaces}}) {
+ my $interface = $self->{interfaces}->{$name};
+ $xml .= $indent . ' <interface name="' . $name . '">' . "\n";
+ foreach my $mname (sort { $a cmp $b } keys %{$interface->{methods}}) {
+ my $method = $interface->{methods}->{$mname};
+ $xml .= $indent . ' <method name="' . $mname . '">' . "\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 . ' <arg ' . (@paramnames ? shift(@paramnames) : "")
+ . 'type="' . $self->to_xml_type($type) . '" direction="in"/>' . "\n";
+ }
+
+ foreach my $type (@{$method->{returns}}) {
+ next if ! ref($type) && exists $magic_type_map{$type};
+ $xml .= $indent . ' <arg ' . (@returnnames ? shift(@returnnames) : "")
+ . 'type="' . $self->to_xml_type($type) . '" direction="out"/>' . "\n";
+ }
+ if ($method->{deprecated}) {
+ $xml .= $indent . ' <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>' . "\n";
+ }
+ if ($method->{no_reply}) {
+ $xml .= $indent . ' <annotation name="org.freedesktop.DBus.Method.NoReply" value="true"/>' . "\n";
+ }
+ $xml .= $indent . ' </method>' . "\n";
+ }
+ foreach my $sname (sort { $a cmp $b } keys %{$interface->{signals}}) {
+ my $signal = $interface->{signals}->{$sname};
+ $xml .= $indent . ' <signal name="' . $sname . '">' . "\n";
+
+ my @paramnames = map{ $_ ? "name=\"$_\" " : '' } ( @{$signal->{paramnames}} );
+
+ foreach my $type (@{$signal->{params}}) {
+ next if ! ref($type) && exists $magic_type_map{$type};
+ $xml .= $indent . ' <arg ' . (@paramnames ? shift(@paramnames) : "")
+ . 'type="' . $self->to_xml_type($type) . '"/>' . "\n";
+ }
+ if ($signal->{deprecated}) {
+ $xml .= $indent . ' <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>' . "\n";
+ }
+ $xml .= $indent . ' </signal>' . "\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 . ' <property name="' . $pname . '" type="' .
+ $self->to_xml_type($type) . '" access="' . $access . '">' . "\n";
+ $xml .= $indent . ' <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>' . "\n";
+ $xml .= $indent . ' </property>' . "\n";
+ } else {
+ $xml .= $indent . ' <property name="' . $pname . '" type="' .
+ $self->to_xml_type($type) . '" access="' . $access . '"/>' . "\n";
+ }
+ }
+
+ $xml .= $indent . ' </interface>' . "\n";
+ }
+
+ #
+ # Interfaces don't have children, objects do
+ #
+ if ($obj) {
+ foreach ( $obj->_get_sub_nodes ) {
+ $xml .= $indent . ' <node name="/' . $_ . '"/>' . "\n";
+ }
+ } else {
+ foreach my $child (@{$self->{children}}) {
+ if (ref($child) eq __PACKAGE__) {
+ $xml .= $child->to_xml($indent . " ");
+ } else {
+ $xml .= $indent . ' <node name="' . $child . '"/>' . "\n";
+ }
+ }
+ }
+
+ $xml .= $indent . "</node>\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<signal> or C<method> and
+C<$direction> is either C<params> or C<returns>. 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<signal> or C<method> and
+C<$direction> is either C<params> or C<returns>. 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<Net::DBus::Exporter>, L<Net::DBus::Binding::Message>
+
+=cut
--- /dev/null
+# -*- 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<Net::DBus::Binding::Message::TYPE*>
+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<Net::DBus::Binding::Value>,
+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<Net::DBus::Binding::Message::TYPE_*>
+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<guess_type> 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<Net::DBus::Binding::Message::TYPE_*>
+
+=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<Net::DBus::Binding::Message::TYPE_*>
+
+=cut
+
+1;
+
+=pod
+
+=back
+
+=head1 AUTHOR
+
+Daniel P. Berrange
+
+=head1 COPYRIGHT
+
+Copyright (C) 2004-2011 Daniel P. Berrange
+
+=head1 SEE ALSO
+
+L<Net::DBus::Binding::Message>
+
+=cut
--- /dev/null
+# -*- 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<Net::DBus::Binding::Message::Signal>,
+L<Net::DBus::Binding::Message::MethodCall>, L<Net::DBus::Binding::Message::MethodReturn>,
+L<Net::DBus::Binding::Message::Error> 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<message> 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<Net::DBus::Binding::Message::MESSAGE_TYPE_*> 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<Net::DBus::Binding::Iterator> 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<Net::DBus::Binding::Iterator> 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<Net::DBus::Binding::Server>, L<Net::DBus::Binding::Connection>, L<Net::DBus::Binding::Message::Signal>, L<Net::DBus::Binding::Message::MethodCall>, L<Net::DBus::Binding::Message::MethodReturn>, L<Net::DBus::Binding::Message::Error>
+
+=cut
--- /dev/null
+# -*- 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<Net::DBus::Binding::> 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<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 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<name> 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<Net::DBus::Binding::Message>
+
+=cut
--- /dev/null
+# -*- 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<Net::DBus::Binding::> 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<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 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<Net::DBus::Binding::Message>
+
+=cut
--- /dev/null
+# -*- 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<Net::DBus::Binding::> 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<call> 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<Net::DBus::Binding::Message>
+
+=cut
--- /dev/null
+# -*- 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<Net::DBus::Binding::> 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<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 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<Net::DBus::Binding::Message>
+
+=cut
--- /dev/null
+# -*- 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<method_call> parameter
+being a reference to the C<Net::DBus::Binding::Message::MethodCall>
+object whose reply is being waiting for. The C<pending_call> 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<Net::DBus::Binding::Message> 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<Net::DBus::Binding::Connection>, L<Net::DBus::Binding::Message>, L<Net::DBus::ASyncReply>
+
+=cut
--- /dev/null
+# -*- 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<address> 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<Net::DBus::Binding::Reactor> object
+as the application event loop, then the 'manage' method on
+that object will call this on your behalf.
+
+=cut
+
+
+sub set_watch_callbacks {
+ my $self = shift;
+ my $add = shift;
+ 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<Net::DBus::Binding::Reactor> object
+as the application event loop, then the 'manage' method on
+that object will call this on your behalf.
+
+=cut
+
+sub set_timeout_callbacks {
+ my $self = shift;
+ my $add = shift;
+ my $remove = shift;
+ my $toggled = shift;
+
+ $self->{add_timeout} = $add;
+ $self->{remove_timeout} = $remove;
+ $self->{toggled_timeout} = $toggled;
+
+ $self->{server}->_set_timeout_callbacks();
+}
+
+=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<Net::DBus::Binding::Connection> 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<Net::DBus::Binding::Connection>, L<Net::DBus::Binding::Bus>, L<Net::DBus::Binding::Message::Signal>, L<Net::DBus::Binding::Message::MethodCall>, L<Net::DBus::Binding::Message::MethodReturn>, L<Net::DBus::Binding::Message::Error>
+
+=cut
--- /dev/null
+# -*- 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<Net::DBus> 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<Net::DBus> 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<Net::DBus>, L<Net::DBus::Binding::Introspector>, L<Net::DBus::Binding::Iterator>
+
+=cut
--- /dev/null
+# -*- 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<Net::DBus::Binding::Connection>
+
+=cut
+
--- /dev/null
+# -*- 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<Net::DBus::Reactor>
+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<method>
+parameter should be the fully qualified function name to invoke, including the
+package name. The optional C<args> parameter is an array reference of parameters
+to be pass to the callback, in addition to those passed into the C<invoke> 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<method>
+parameter should be the name of the method to invoke, while the C<object> parameter
+should be a blessed object on which the method will be invoked. The optional C<args>
+parameter is an array reference of parameters to be pass to the callback, in addition
+to those passed into the C<invoke> 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<invoke>
+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<Net::DBus::Reactor>
+
+=cut
+
--- /dev/null
+# -*- 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<Net::DBus>,
+L<Net::DBus::RemoteService>, L<Net::DBus::Service>,
+L<Net::DBus::RemoteObject>, L<Net::DBus::Object>. 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<print>
+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<Net::DBus>, L<Net::DBus::RemoteService>, L<Net::DBus::Service>,
+L<Net::DBus::RemoteObject>, L<Net::DBus::Object>, L<Data::Dumper>.
+
+=cut
--- /dev/null
+# -*- 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<Net::DBus::Error>
+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<name>
+parameter, and long descriptive text is provided by the
+C<message> parameter. The C<name> 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<Net::DBus>, L<Net::DBus::Object>
+
+=cut
--- /dev/null
+# -*- 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<Net::DBus::Exporter> 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<Net::DBus::Object>, 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<perldata>).
+
+=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<ARRAY-TYPE>. The C<ARRAY-TYPE>
+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<perldata>). 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<KEY-TYPE> is the name of the scalar data type used for the dictionary
+keys. The C<VALUE-TYPE> 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<perldata>). 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<magic> 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<dbus_no_strict_exports>. 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 <dan@berrange.com>
+
+=head1 COPYRIGHT
+
+Copright (C) 2004-2011, Daniel Berrange.
+
+=head1 SEE ALSO
+
+L<Net::DBus::Object>, L<Net::DBus::Binding::Introspector>
+
+=cut
--- /dev/null
+# -*- 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<Exporter> module is used to export
+methods within a script, the L<Net::DBus::Exporter> module is
+used to export methods (and signals) to the message bus.
+
+All packages inheriting from this, will automatically have the
+interface C<org.freedesktop.DBus.Introspectable> registered
+with L<Net::DBus::Exporter>, and the C<Introspect> 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<Net::DBus::Service>.
+The latter is typically obtained by calling the C<export_service>
+method on the L<Net::DBus> 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<Net::DBus::Object>.
+
+=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<disconnect> 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<Net::DBus::Service> 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<Net::DBus::Exporter> by calling the
+C<dbus_signal> 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<Net::DBus::Exporter> by calling the
+C<dbus_signal> 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<Net::DBus::Exporter> by calling the
+C<dbus_signal> 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<Net::DBus>, L<Net::DBus::Service>, L<Net::DBus::RemoteObject>,
+L<Net::DBus::Exporter>.
+
+=cut
--- /dev/null
+# -*- 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<main>
+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<Net::DBus::Binding::Connection> or C<Net::DBus::Binding::Server> object
+for management by the event loop. This basically involves
+hooking up the watch & timeout callbacks to the event loop.
+For connections it will also register a hook to invoke the
+C<dispatch> method periodically.
+
+=cut
+
+sub manage {
+ my $self = shift;
+ my $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<shutdown> 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<Net::DBus::Callback> object to invoke each time
+an event occurs. The optional C<$status> parameter is
+a boolean value to specify whether the watch is
+initially enabled.
+
+=cut
+
+sub add_read {
+ my $self = shift;
+ $self->_add("read", @_);
+}
+
+=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<Net::DBus::Callback> object to invoke
+each time an event occurs. The optional C<$status>
+parameter is a boolean value to specify whether the
+watch is initially enabled.
+
+=cut
+
+sub add_write {
+ my $self = shift;
+ $self->_add("write", @_);
+}
+
+
+=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<Net::DBus::Callback> object to invoke
+each time an event occurs. The optional C<$status>
+parameter is a boolean value to specify whether the
+watch is initially enabled.
+
+=cut
+
+sub add_exception {
+ my $self = shift;
+ $self->_add("exception", @_);
+}
+
+
+=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<Net::DBus::Callback> object to invoke
+each time the timeout expires. The optional C<$status>
+parameter is a boolean value to specify whether the
+timeout is initially enabled. The return parameter is
+a unique identifier which can be used to later remove
+or disable the timeout.
+
+=cut
+
+sub add_timeout {
+ my $self = shift;
+ my $interval = shift;
+ my $callback = shift;
+ my $enabled = shift;
+ $enabled = 1 unless defined $enabled;
+
+ 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<Net::DBus::Callback>
+class to invoke. The C<$status> parameter determines
+whether the hook is initially enabled, or disabled.
+The return parameter is a unique id which should
+be used to later remove, or disable the hook.
+
+=cut
+
+sub add_hook {
+ my $self = shift;
+ my $callback = shift;
+ my $enabled = shift;
+ $enabled = 1 unless defined $enabled;
+
+ 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<Net::DBus::Callback>, L<Net::DBus::Connection>, L<Net::DBus::Server>
+
+=head1 AUTHOR
+
+Daniel Berrange E<lt>dan@berrange.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2004-2011 by Daniel Berrange
+
+=cut
--- /dev/null
+# -*- 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<Net::DBus::RemoteService> method, and C<$object_path> is the identifier of
+an object exported by this service, for example C</org/freedesktop/DBus>. 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<get_object> method on L<Net::DBus::RemoteService>, 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<Net::DBus::RemoteObject> 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<Net::DBus::RemoteService>
+
+=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<Net::DBus::RemoteObject>. 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<disconnect_from_signal>
+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<connect_to_signal> 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 <dan@berrange.com>
+
+=head1 COPYRIGHT
+
+Copright (C) 2004-2011, Daniel Berrange.
+
+=head1 SEE ALSO
+
+L<Net::DBus::RemoteService>, L<Net::DBus::Object>
+
+=cut
--- /dev/null
+# -*- 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<Net::DBus>, 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<org.freedesktop.DBus>. There is generally no need to call
+this constructor, instead the C<get_service> method on L<Net::DBus> 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<Net::DBus>.
+
+=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<Net::DBus::RemoteObject>.
+
+=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 <dan@berrange.com>
+
+=head1 COPYRIGHT
+
+Copright (C) 2004-2011, Daniel Berrange.
+
+=head1 SEE ALSO
+
+L<Net::DBus::RemoteObject>, L<Net::DBus::Service>, L<Net::DBus>
+
+=cut
--- /dev/null
+# -*- 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<Net::DBus> 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<export_service> method on the L<Net::DBus> 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<Net::DBus> 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<Net::DBus>, L<Net::DBus::Object>, L<Net::DBus::RemoteService>
+
+=cut
--- /dev/null
+# -*- 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<Net::DBus::Binding::Connection>
+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<Net::DBus::Test::MockObject> 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<test> method on the L<Net::DBus> 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<send_with_reply_and_block>
+method. If the message is a signal it will be queued up for processing
+by the C<dispatch> 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<Net::DBus::Binding::Message::MethodCall>
+and the return C<$reply> will be an instance of C<Net::DBus::Binding::Message::MethodReturn>.
+It is also possible that an error will be thrown, with
+the thrown error being blessed into the C<Net::DBus::Error>
+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<Net::DBus::Binding::Message> 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<Net::DBus::Binding::Message> 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<register_object_path>
+or C<register_fallback> 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<Net::DBus::Binding::Connection>,
+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<Net::DBus>, L<Net::DBus::Test::MockObject>, L<Net::DBus::Binding::Connection>,
+L<http://www.mockobjects.com/Faq.html>
+
+=cut
--- /dev/null
+# -*- 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<Net::DBus::Binding::Iterator>
+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<iterator>
+method on the L<Net::DBus::Test::MockMessage> 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<Net::DBus::Binding::Message::TYPE*>
+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<Net::DBus::Binding::Value>,
+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<Net::DBus::Binding::Message::TYPE_*>
+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<guess_type> 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<Net::DBus::Binding::Message::TYPE_*>
+
+=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<Net::DBus::Binding::Message::TYPE_*>
+
+=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<Net::DBus::Binding::Iterator>,
+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<Net::DBus::Test::MockMessage>, L<Net::DBus::Binding::Iterator>,
+L<http://www.mockobjects.com/Faq.html>
+
+=cut
--- /dev/null
+# -*- 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<Net::DBus::Binding::Message>
+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<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 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<replyto> 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<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 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<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 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<Net::DBus::Test::MockMessage::MESSAGE_TYPE_*> 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<name> 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<Net::DBus::Binding::Iterator> 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<Net::DBus::Binding::Iterator> 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<Net::DBus::Binding::Message>, L<Net::DBus::Test::MockConnection>, L<Net::DBus::Test::MockIterator>
+
+=cut
--- /dev/null
+# -*- 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<Net::DBus::Object> 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<Net::DBus::MockBus> 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<Net::DBus::Service> 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<Net::DBus::Service> 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<Net::DBus::Binding::Message>
+
+=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<Net::DBus::Binding::Message::Signal> 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<name>, giving the error name, and the
+second, C<description>, 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<Net::DBus::Binding::Object>,
+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<Net::DBus>, L<Net::DBus::Object>, L<Net::DBus::Test::MockConnection>,
+L<http://www.mockobjects.com/Faq.html>
+
+=cut
--- /dev/null
+# -*- 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<Net::DBus::Tutorial::ExportingObjects>
+
+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<Net::DBus::Tutorial::UsingObjects>
+
+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<Net::DBus>, L<Net::DBus::Object>, L<Net::DBus::RemoteObject>,
+L<http://freedesktop.org/>
+
+=head1 AUTHORS
+
+Daniel P. Berrange L<mailto:dan@berrange.com>
+
+=head1 COPYRIGHT
+
+Copyright 2005 Daniel P. Berrange
+
+=cut
--- /dev/null
+# -*- 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<Music::Player> 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<Net::DBus::Object>. 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<Net::DBus::Object> expects to be given to parameters,
+a handle to the L<Net::DBus::Service> 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<get_service>
+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<perltoot>):
+
+ 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<die>
+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<get_track_types> 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<Net::DBus::Tutorial::UsingObjects>. 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<Introspection>, 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<org.cpan> as the first component, followed by the package
+name of the module (replacing :: with .), eg C<org.cpan.music.player.manager>. If it is
+not planned to host the module on CPAN, a personal/project domain might be
+used eg C<com.berrange.music.player.manager>. The interface for an object is defined
+by loading the L<Net::DBus::Exporter> 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<Net::DBus::Exporter> module provides a method
+C<dbus_method> 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<dbus_method> 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<Net::DBus::Service> module provides the means to register
+a service. Its constructor expects a reference to the bus object
+(an instance of L<Net::DBus>), 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<org.cpan.Music.Player>.
+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<Net::DBus::Service> automatically provides one special
+object to all services, under the path C</org/freedesktop/DBus/Exporter>.
+This object implements the C<org.freedesktop.DBus.Exporter> interface
+which has a method C<ListObject>. 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<session> or <system> methods on L<Net::DBus>
+to get a handle to the desired bus, while in the latter case, the C<find>
+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</usr/bin/music-player.pl>, 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<activation>. 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</usr/share/dbus-1/services>. The file
+should be named to match the service name, with the file extension
+C<.service> appended. eg, C</usr/share/dbus-1/services/org.cpan.music.player.service>
+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<Net::DBus::Tutorial> for details of other tutorials, and
+L<Net::DBus> for API documentation
+
+=head1 AUTHORS
+
+Daniel Berrange <dan@berrange.com>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2005 Daniel P. Berrange
+
+=cut
--- /dev/null
+# -*- 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<Net::DBus::Tutorial> for details of other tutorials, and
+L<Net::DBus> for API documentation
+
+=head1 AUTHORS
+
+Daniel Berrange <dan@berrange.com>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2006 Daniel P. Berrange
+
+=cut
--- /dev/null
+# -*- 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' );
--- /dev/null
+# -*- 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();
--- /dev/null
+# -*- 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();
--- /dev/null
+# -*- 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");
+
--- /dev/null
+# -*- 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};
+}
--- /dev/null
+# -*- 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++;
+}
--- /dev/null
+# -*- 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");
--- /dev/null
+# -*- 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;
+<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"
+"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">
+<node name="org.example.Object.OtherObject">
+ <interface name="org.example.SomeInterface">
+ <method name="goodbye">
+ <arg name="ooh" type="a(is)" direction="in"/>
+ <arg name="ahh" type="s" direction="out"/>
+ <arg name="eek" type="s" direction="out"/>
+ </method>
+ <method name="hello">
+ <arg name="wibble" type="i" direction="in"/>
+ <arg name="eek" type="i" direction="in"/>
+ <arg type="(iy)" direction="in"/>
+ <arg name="frob" type="i" direction="out"/>
+ </method>
+ <signal name="meltdown">
+ <arg type="i"/>
+ <arg type="y"/>
+ </signal>
+ <property name="age" type="i" access="read"/>
+ <property name="email" type="s" access="read"/>
+ <property name="name" type="s" access="readwrite"/>
+ <property name="parents" type="as" access="readwrite"/>
+ </interface>
+</node>
+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;
+<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"
+"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">
+<node name="org.example.Object">
+ <interface name="org.example.OtherInterface">
+ <method name="hitme">
+ <arg type="i" direction="in"/>
+ <arg type="u" direction="in"/>
+ </method>
+ <property name="salary" type="i" access="read"/>
+ <property name="title" type="s" access="readwrite"/>
+ </interface>
+ <interface name="org.example.SomeInterface">
+ <method name="goodbye">
+ <arg type="aa{is}" direction="in"/>
+ <arg type="s" direction="out"/>
+ <arg type="as" direction="out"/>
+ </method>
+ <method name="hello">
+ <arg type="i" direction="in"/>
+ <arg type="i" direction="in"/>
+ <arg type="(iy)" direction="in"/>
+ <arg type="u" direction="out"/>
+ </method>
+ <signal name="meltdown">
+ <arg type="i"/>
+ <arg type="y"/>
+ </signal>
+ </interface>
+ <node name="org.example.Object.SubObject"/>
+ <node name="org.example.Object.OtherObject">
+ <interface name="org.example.SomeInterface">
+ <method name="goodbye">
+ <arg name="ooh" type="a(is)" direction="in"/>
+ <arg name="ahh" type="s" direction="out"/>
+ <arg name="eek" type="s" direction="out"/>
+ </method>
+ <method name="hello">
+ <arg name="wibble" type="i" direction="in"/>
+ <arg name="eek" type="i" direction="in"/>
+ <arg type="(iy)" direction="in"/>
+ <arg name="frob" type="i" direction="out"/>
+ </method>
+ <signal name="meltdown">
+ <arg type="i"/>
+ <arg type="y"/>
+ </signal>
+ <property name="age" type="i" access="read"/>
+ <property name="email" type="s" access="read"/>
+ <property name="name" type="s" access="readwrite"/>
+ <property name="parents" type="as" access="readwrite"/>
+ </interface>
+ </node>
+</node>
+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");
+}
--- /dev/null
+# -*- perl -*-
+use Test::More tests => 10;
+
+use strict;
+use warnings;
+
+BEGIN {
+ use_ok('Net::DBus::Binding::Introspector');
+};
+
+local $/ = undef;
+my $xml = <DATA>;
+
+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__
+<?xml version="1.0" standalone='no'?><!--*-nxml-*-->
+<?xml-stylesheet type="text/xsl" href="introspect.xsl"?>
+<!DOCTYPE node SYSTEM "introspect.dtd">
+
+<!-- $Id: ServiceBrowser.introspect 948 2005-11-12 18:55:52Z lennart $ -->
+
+<!--
+ This file is part of avahi.
+
+ avahi is free software; you can redistribute it and/or modify it
+ under the terms of the GNU Lesser General Public License as
+ published by the Free Software Foundation; either version 2 of the
+ License, or (at your option) any later version.
+
+ avahi 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 Lesser General Public
+ License along with avahi; if not, write to the Free Software
+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+ 02111-1307 USA.
+-->
+
+<node>
+
+ <interface name="org.freedesktop.DBus.Introspectable">
+ <method name="Introspect">
+ <arg name="data" type="s" direction="out" />
+ </method>
+ </interface>
+
+ <interface name="org.freedesktop.Avahi.ServiceBrowser">
+
+ <method name="Free"/>
+
+ <signal name="ItemNew">
+ <arg name="interface" type="i"/>
+ <arg name="protocol" type="i"/>
+ <arg name="name" type="s"/>
+ <arg name="type" type="s"/>
+ <arg name="domain" type="s"/>
+ <arg name="flags" type="u"/>
+ </signal>
+
+ <signal name="ItemRemove">
+ <arg name="interface" type="i"/>
+ <arg name="protocol" type="i"/>
+ <arg name="name" type="s"/>
+ <arg name="type" type="s"/>
+ <arg name="domain" type="s"/>
+ <arg name="flags" type="u"/>
+ </signal>
+
+ <signal name="Failure">
+ <arg name="error" type="s"/>
+ </signal>
+
+ <signal name="AllForNow"/>
+
+ <signal name="CacheExhausted"/>
+
+ </interface>
+</node>
--- /dev/null
+# -*- 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;
+<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"
+"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">
+<node name="/org/example/MyObject">
+ <interface name="_org.example._some_9object">
+ <method name="DemoInterfaceName1">
+ <arg type="s" direction="out"/>
+ </method>
+ </interface>
+ <interface name="org.example.MyObject">
+ <method name="Everything">
+ <arg type="s" direction="in"/>
+ <arg type="i" direction="out"/>
+ </method>
+ <method name="EverythingAnnotate">
+ <arg type="s" direction="in"/>
+ <arg type="i" direction="out"/>
+ <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
+ <annotation name="org.freedesktop.DBus.Method.NoReply" value="true"/>
+ </method>
+ <method name="EverythingNegativeAnnotate">
+ <arg type="s" direction="in"/>
+ <arg type="i" direction="out"/>
+ </method>
+ <method name="NoArgs">
+ <arg type="i" direction="out"/>
+ </method>
+ <method name="NoArgsAnnotate">
+ <arg type="i" direction="out"/>
+ <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
+ </method>
+ <method name="NoArgsReturns">
+ </method>
+ <method name="NoArgsReturnsAnnotate">
+ <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
+ </method>
+ <method name="NoReturns">
+ <arg name="wizz" type="s" direction="in"/>
+ </method>
+ <method name="NoReturnsAnnotate">
+ <arg type="s" direction="in"/>
+ <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
+ </method>
+ </interface>
+ <interface name="org.example.OtherObject">
+ <method name="EverythingInterface">
+ <arg type="s" direction="in"/>
+ <arg type="i" direction="out"/>
+ </method>
+ <method name="EverythingInterfaceAnnotate">
+ <arg type="s" direction="in"/>
+ <arg type="i" direction="out"/>
+ <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
+ <annotation name="org.freedesktop.DBus.Method.NoReply" value="true"/>
+ </method>
+ <method name="EverythingInterfaceNegativeAnnotate">
+ <arg type="s" direction="in"/>
+ <arg type="i" direction="out"/>
+ </method>
+ <method name="NoArgsInterface">
+ <arg type="i" direction="out"/>
+ </method>
+ <method name="NoArgsInterfaceAnnotate">
+ <arg name="two" type="i" direction="out"/>
+ <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
+ </method>
+ <method name="NoArgsReturnsInterface">
+ </method>
+ <method name="NoArgsReturnsInterfaceAnnotate">
+ <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
+ </method>
+ <method name="NoReturnsInterface">
+ <arg type="s" direction="in"/>
+ </method>
+ <method name="NoReturnsInterfaceAnnotate">
+ <arg name="one" type="s" direction="in"/>
+ <annotation name="org.freedesktop.DBus.Deprecated" value="true"/>
+ </method>
+ </interface>
+ <interface name="org.freedesktop.DBus.Introspectable">
+ <method name="Introspect">
+ <arg type="s" direction="out"/>
+ </method>
+ </interface>
+ <interface name="org.freedesktop.DBus.Properties">
+ <method name="Get">
+ <arg type="s" direction="in"/>
+ <arg type="s" direction="in"/>
+ <arg type="v" direction="out"/>
+ </method>
+ <method name="GetAll">
+ <arg type="s" direction="in"/>
+ <arg type="a{sv}" direction="out"/>
+ </method>
+ <method name="Set">
+ <arg type="s" direction="in"/>
+ <arg type="s" direction="in"/>
+ <arg type="v" direction="in"/>
+ </method>
+ </interface>
+</node>
+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");
+ }
+
+
+}
--- /dev/null
+# -*- 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;
+<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"
+"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">
+<node name="/org/example/Object/OtherObject">
+ <interface name="org.freedesktop.DBus.Introspectable">
+ <method name="Introspect">
+ <arg type="s" direction="out"/>
+ </method>
+ </interface>
+ <interface name="org.freedesktop.DBus.Properties">
+ <method name="Get">
+ <arg type="s" direction="in"/>
+ <arg type="s" direction="in"/>
+ <arg type="v" direction="out"/>
+ </method>
+ <method name="GetAll">
+ <arg type="s" direction="in"/>
+ <arg type="a{sv}" direction="out"/>
+ </method>
+ <method name="Set">
+ <arg type="s" direction="in"/>
+ <arg type="s" direction="in"/>
+ <arg type="v" direction="in"/>
+ </method>
+ </interface>
+</node>
+EOF
+
+is($xml_got, $xml_expect, "xml data matches");
+
--- /dev/null
+# -*- 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)");
+}
--- /dev/null
+# -*- 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);
+}
+
--- /dev/null
+# -*- 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;
+<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"
+"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">
+<node name="/org/example/MyObject">
+ <interface name="org.example.MyObject">
+ <property name="age" type="i" access="write"/>
+ <property name="email" type="s" access="read"/>
+ <property name="height" type="d" access="write"/>
+ <property name="name" type="s" access="readwrite"/>
+ <property name="parents" type="as" access="readwrite"/>
+ </interface>
+ <interface name="org.freedesktop.DBus.Introspectable">
+ <method name="Introspect">
+ <arg type="s" direction="out"/>
+ </method>
+ </interface>
+ <interface name="org.freedesktop.DBus.Properties">
+ <method name="Get">
+ <arg type="s" direction="in"/>
+ <arg type="s" direction="in"/>
+ <arg type="v" direction="out"/>
+ </method>
+ <method name="GetAll">
+ <arg type="s" direction="in"/>
+ <arg type="a{sv}" direction="out"/>
+ </method>
+ <method name="Set">
+ <arg type="s" direction="in"/>
+ <arg type="s" direction="in"/>
+ <arg type="v" direction="in"/>
+ </method>
+ </interface>
+</node>
+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");
+}
--- /dev/null
+# -*- 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;
+<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"
+"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">
+<node name="/org/example/MyObject">
+ <interface name="org.example.MyObject">
+ <method name="test_set_caller">
+ </method>
+ <method name="test_set_multi_args1">
+ <arg type="s" direction="in"/>
+ </method>
+ <method name="test_set_multi_args2">
+ <arg type="s" direction="in"/>
+ </method>
+ <method name="test_set_multi_args3">
+ <arg type="s" direction="in"/>
+ <arg type="s" direction="in"/>
+ </method>
+ <method name="test_set_serial">
+ </method>
+ </interface>
+ <interface name="org.freedesktop.DBus.Introspectable">
+ <method name="Introspect">
+ <arg type="s" direction="out"/>
+ </method>
+ </interface>
+ <interface name="org.freedesktop.DBus.Properties">
+ <method name="Get">
+ <arg type="s" direction="in"/>
+ <arg type="s" direction="in"/>
+ <arg type="v" direction="out"/>
+ </method>
+ <method name="GetAll">
+ <arg type="s" direction="in"/>
+ <arg type="a{sv}" direction="out"/>
+ </method>
+ <method name="Set">
+ <arg type="s" direction="in"/>
+ <arg type="s" direction="in"/>
+ <arg type="v" direction="in"/>
+ </method>
+ </interface>
+</node>
+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");
+}
--- /dev/null
+# -*- 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;
+<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"
+"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">
+<node name="/base">
+ <interface name="com.dbelser.test.type1">
+ <method name="version">
+ <arg type="s" direction="out"/>
+ </method>
+ </interface>
+ <interface name="org.freedesktop.DBus.Introspectable">
+ <method name="Introspect">
+ <arg type="s" direction="out"/>
+ </method>
+ </interface>
+ <interface name="org.freedesktop.DBus.Properties">
+ <method name="Get">
+ <arg type="s" direction="in"/>
+ <arg type="s" direction="in"/>
+ <arg type="v" direction="out"/>
+ </method>
+ <method name="GetAll">
+ <arg type="s" direction="in"/>
+ <arg type="a{sv}" direction="out"/>
+ </method>
+ <method name="Set">
+ <arg type="s" direction="in"/>
+ <arg type="s" direction="in"/>
+ <arg type="v" direction="in"/>
+ </method>
+ </interface>
+ <node name="/branch_1"/>
+ <node name="/branch_2"/>
+ <node name="/branch_3"/>
+</node>
+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;
+<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"
+"http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">
+<node name="/base/branch_2">
+ <interface name="com.dbelser.test.type2">
+ <method name="version">
+ <arg type="s" direction="out"/>
+ </method>
+ </interface>
+ <interface name="org.freedesktop.DBus.Introspectable">
+ <method name="Introspect">
+ <arg type="s" direction="out"/>
+ </method>
+ </interface>
+ <interface name="org.freedesktop.DBus.Properties">
+ <method name="Get">
+ <arg type="s" direction="in"/>
+ <arg type="s" direction="in"/>
+ <arg type="v" direction="out"/>
+ </method>
+ <method name="GetAll">
+ <arg type="s" direction="in"/>
+ <arg type="a{sv}" direction="out"/>
+ </method>
+ <method name="Set">
+ <arg type="s" direction="in"/>
+ <arg type="s" direction="in"/>
+ <arg type="v" direction="in"/>
+ </method>
+ </interface>
+ <node name="/skip"/>
+</node>
+EOF
+is($xml_got, $xml_expect, "xml data matches");
--- /dev/null
+# -*- 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");
--- /dev/null
+# -*- 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");
+
--- /dev/null
+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 );
projects / platform / upstream / perl-Net-DBus.git / commitdiff