[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master c540f33 1/2: Add D-Bus monitor
|
From: |
Michael Albinus |
|
Subject: |
master c540f33 1/2: Add D-Bus monitor |
|
Date: |
Sat, 26 Sep 2020 05:39:02 -0400 (EDT) |
branch: master
commit c540f3323da96eadf41ccfa4e23ec2a5124343b8
Author: Michael Albinus <michael.albinus@gmx.de>
Commit: Michael Albinus <michael.albinus@gmx.de>
Add D-Bus monitor
* lisp/net/dbus.el (dbus-interface-monitoring): New defconst.
(dbus-call-method, dbus-call-method-asynchronously)
(dbus-send-signal, dbus-method-return-internal)
(dbus-method-error-internal, dbus-check-arguments): Accept also
:system-private and :session-private.
(dbus-check-event, dbus-event-path-name)
(dbus-event-interface-name)
(dbus-event-member-name, dbus-property-handler)
(dbus-handle-bus-disconnect): Adapt according to new structure.
(dbus-handle-event): Handle also monitor events.
(dbus-event-destination-name, dbus-event-handler)
(dbus-event-arguments, dbus-register-monitor, dbus-monitor-handler):
New defuns.
* src/dbusbind.c (XD_DBUS_VALIDATE_BUS_ADDRESS, xd_remove_watch)
(Fdbus__init_bus): Accept also :system-private and :session-private.
(xd_read_message_1): Add destination and error_name to
dbus-event. Handle monitor events.
(syms_of_dbusbind): Declare QCsystem_private, QCsession_private
and QCmonitor.
(dbus-registered-objects-table): Fix docstring.
---
lisp/net/dbus.el | 295 +++++++++++++++++++++++++++++++++++++++++++------------
src/dbusbind.c | 139 ++++++++++++++++++++------
2 files changed, 341 insertions(+), 93 deletions(-)
diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el
index 86db7cb..da47e5b 100644
--- a/lisp/net/dbus.el
+++ b/lisp/net/dbus.el
@@ -144,6 +144,17 @@ See URL
`https://dbus.freedesktop.org/doc/dbus-specification.html#standard-inter
;; </signal>
;; </interface>
+(defconst dbus-interface-monitoring (concat dbus-interface-dbus ".Monitoring")
+ "The monitoring interface.
+See URL
`https://dbus.freedesktop.org/doc/dbus-specification.html#bus-messages-become-monitor'.")
+
+;; <interface name="org.freedesktop.DBus.Monitoring">
+;; <method name="BecomeMonitor">
+;; <arg name="rule" type="as" direction="in"/>
+;; <arg name="flags" type="u" direction="in"/> ;; Not used, must be 0.
+;; </method>
+;; </interface>
+
(defconst dbus-interface-local (concat dbus-interface-dbus ".Local")
"An interface whose methods can only be invoked by the local
implementation.")
@@ -336,7 +347,8 @@ object is returned instead of a list containing this single
Lisp object.
(or (featurep 'dbusbind)
(signal 'dbus-error (list "Emacs not compiled with dbus support")))
- (or (memq bus '(:system :session)) (stringp bus)
+ (or (memq bus '(:system :session :system-private :session-private))
+ (stringp bus)
(signal 'wrong-type-argument (list 'keywordp bus)))
(or (stringp service)
(signal 'wrong-type-argument (list 'stringp service)))
@@ -440,7 +452,8 @@ Example:
(or (featurep 'dbusbind)
(signal 'dbus-error (list "Emacs not compiled with dbus support")))
- (or (memq bus '(:system :session)) (stringp bus)
+ (or (memq bus '(:system :session :system-private :session-private))
+ (stringp bus)
(signal 'wrong-type-argument (list 'keywordp bus)))
(or (stringp service)
(signal 'wrong-type-argument (list 'stringp service)))
@@ -490,7 +503,8 @@ Example:
(or (featurep 'dbusbind)
(signal 'dbus-error (list "Emacs not compiled with dbus support")))
- (or (memq bus '(:system :session)) (stringp bus)
+ (or (memq bus '(:system :session :system-private :session-private))
+ (stringp bus)
(signal 'wrong-type-argument (list 'keywordp bus)))
(or (null service) (stringp service)
(signal 'wrong-type-argument (list 'stringp service)))
@@ -510,7 +524,8 @@ This is an internal function, it shall not be used outside
dbus.el."
(or (featurep 'dbusbind)
(signal 'dbus-error (list "Emacs not compiled with dbus support")))
- (or (memq bus '(:system :session)) (stringp bus)
+ (or (memq bus '(:system :session :system-private :session-private))
+ (stringp bus)
(signal 'wrong-type-argument (list 'keywordp bus)))
(or (stringp service)
(signal 'wrong-type-argument (list 'stringp service)))
@@ -527,7 +542,8 @@ This is an internal function, it shall not be used outside
dbus.el."
(or (featurep 'dbusbind)
(signal 'dbus-error (list "Emacs not compiled with dbus support")))
- (or (memq bus '(:system :session)) (stringp bus)
+ (or (memq bus '(:system :session :system-private :session-private))
+ (stringp bus)
(signal 'wrong-type-argument (list 'keywordp bus)))
(or (stringp service)
(signal 'wrong-type-argument (list 'stringp service)))
@@ -545,7 +561,8 @@ This is an internal function, it shall not be used outside
dbus.el."
(or (featurep 'dbusbind)
(signal 'dbus-error (list "Emacs not compiled with dbus support")))
- (or (memq bus '(:system :session)) (stringp bus)
+ (or (memq bus '(:system :session :system-private :session-private))
+ (stringp bus)
(signal 'wrong-type-argument (list 'keywordp bus)))
(or (stringp service)
(signal 'wrong-type-argument (list 'stringp service)))
@@ -1018,19 +1035,29 @@ STRING must have been encoded with
`dbus-escape-as-identifier'."
"Check whether EVENT is a well formed D-Bus event.
EVENT is a list which starts with symbol `dbus-event':
- (dbus-event BUS TYPE SERIAL SERVICE PATH INTERFACE MEMBER HANDLER &rest ARGS)
+ (dbus-event BUS TYPE SERIAL SERVICE DESTINATION PATH
+ INTERFACE MEMBER HANDLER &rest ARGS)
BUS identifies the D-Bus the message is coming from. It is
-either a Lisp symbol, `:system' or `:session', or a string
-denoting the bus address. TYPE is the D-Bus message type which
-has caused the event, SERIAL is the serial number of the received
-D-Bus message. SERVICE and PATH are the unique name and the
-object path of the D-Bus object emitting the message. INTERFACE
-and MEMBER denote the message which has been sent. HANDLER is
-the function which has been registered for this message. ARGS
-are the typed arguments as returned from the message. They are
-passed to HANDLER without type information, when it is called
-during event handling in `dbus-handle-event'.
+either a Lisp symbol, `:system', `:session', `:systemp-private'
+or `:session-private', or a string denoting the bus address.
+
+TYPE is the D-Bus message type which has caused the event, SERIAL
+is the serial number of the received D-Bus message when TYPE is
+equal `dbus-message-type-method-return' or `dbus-message-type-error'.
+
+SERVICE and PATH are the unique name and the object path of the
+D-Bus object emitting the message. DESTINATION is the D-Bus name
+the message is dedicated to, or nil in case thje message is a
+broadcast signal.
+
+INTERFACE and MEMBER denote the message which has been sent.
+When TYPE is `dbus-message-type-error', MEMBER is the error name.
+
+HANDLER is the function which has been registered for this
+message. ARGS are the typed arguments as returned from the
+message. They are passed to HANDLER without type information,
+when it is called during event handling in `dbus-handle-event'.
This function signals a `dbus-error' if the event is not well
formed."
@@ -1038,7 +1065,7 @@ formed."
(unless (and (listp event)
(eq (car event) 'dbus-event)
;; Bus symbol.
- (or (symbolp (nth 1 event))
+ (or (keywordp (nth 1 event))
(stringp (nth 1 event)))
;; Type.
(and (natnump (nth 2 event))
@@ -1050,20 +1077,26 @@ formed."
(= dbus-message-type-error (nth 2 event))
(or (stringp (nth 4 event))
(null (nth 4 event))))
- ;; Object path.
+ ;; Destination.
(or (= dbus-message-type-method-return (nth 2 event))
(= dbus-message-type-error (nth 2 event))
- (stringp (nth 5 event)))
- ;; Interface.
+ (or (stringp (nth 5 event))
+ (null (nth 5 event))))
+ ;; Object path.
(or (= dbus-message-type-method-return (nth 2 event))
(= dbus-message-type-error (nth 2 event))
(stringp (nth 6 event)))
- ;; Member.
+ ;; Interface.
(or (= dbus-message-type-method-return (nth 2 event))
(= dbus-message-type-error (nth 2 event))
(stringp (nth 7 event)))
+ ;; Member.
+ (or (= dbus-message-type-method-return (nth 2 event))
+ (stringp (nth 8 event)))
;; Handler.
- (functionp (nth 8 event)))
+ (functionp (nth 9 event))
+ ;; Arguments.
+ (listp (nthcdr 10 event)))
(signal 'dbus-error (list "Not a valid D-Bus event" event))))
(defun dbus-delete-types (&rest args)
@@ -1103,28 +1136,36 @@ part of the event, is called with arguments ARGS
(without type information).
If the HANDLER returns a `dbus-error', it is propagated as return message."
(interactive "e")
(condition-case err
- (let (args result)
+ (let (monitor args result)
;; We ignore not well-formed events.
(dbus-check-event event)
;; Remove type information.
- (setq args (mapcar #'dbus-delete-types (nthcdr 9 event)))
- ;; Error messages must be propagated.
- (when (= dbus-message-type-error (nth 2 event))
- (signal 'dbus-error args))
- ;; Apply the handler.
- (setq result (apply (nth 8 event) args))
- ;; Return an (error) message when it is a message call.
- (when (= dbus-message-type-method-call (nth 2 event))
- (dbus-ignore-errors
- (if (eq (car-safe result) :error)
- (apply #'dbus-method-error-internal
- (nth 1 event) (nth 4 event) (nth 3 event) (cdr result))
- (if (eq result :ignore)
- (dbus-method-return-internal
- (nth 1 event) (nth 4 event) (nth 3 event))
- (apply #'dbus-method-return-internal
- (nth 1 event) (nth 4 event) (nth 3 event)
- (if (consp result) result (list result))))))))
+ (setq args (mapcar #'dbus-delete-types (nthcdr 10 event)))
+ (setq monitor
+ (gethash
+ (list :monitor (nth 1 event)) dbus-registered-objects-table))
+ (if monitor
+ ;; A monitor event shall not trigger other operations, and
+ ;; it shall not trigger D-Bus errors.
+ (setq result (dbus-ignore-errors (apply (nth 9 event) args)))
+ ;; Error messages must be propagated. The error name is in
+ ;; the member slot.
+ (when (= dbus-message-type-error (nth 2 event))
+ (signal 'dbus-error (cons (nth 8 event) args)))
+ ;; Apply the handler.
+ (setq result (apply (nth 9 event) args))
+ ;; Return an (error) message when it is a message call.
+ (when (= dbus-message-type-method-call (nth 2 event))
+ (dbus-ignore-errors
+ (if (eq (car-safe result) :error)
+ (apply #'dbus-method-error-internal
+ (nth 1 event) (nth 4 event) (nth 3 event) (cdr result))
+ (if (eq result :ignore)
+ (dbus-method-return-internal
+ (nth 1 event) (nth 4 event) (nth 3 event))
+ (apply #'dbus-method-return-internal
+ (nth 1 event) (nth 4 event) (nth 3 event)
+ (if (consp result) result (list result)))))))))
;; Error handling.
(dbus-error
;; Return an error message when it is a message call.
@@ -1172,13 +1213,21 @@ formed."
(dbus-check-event event)
(nth 4 event))
+(defun dbus-event-destination-name (event)
+ "Return the name of the D-Bus object the event is dedicated to.
+The result is a string. EVENT is a D-Bus event, see `dbus-check-event'.
+This function signals a `dbus-error' if the event is not well
+formed."
+ (dbus-check-event event)
+ (nth 5 event))
+
(defun dbus-event-path-name (event)
"Return the object path of the D-Bus object the event is coming from.
The result is a string. EVENT is a D-Bus event, see `dbus-check-event'.
This function signals a `dbus-error' if the event is not well
formed."
(dbus-check-event event)
- (nth 5 event))
+ (nth 6 event))
(defun dbus-event-interface-name (event)
"Return the interface name of the D-Bus object the event is coming from.
@@ -1186,15 +1235,32 @@ The result is a string. EVENT is a D-Bus event, see
`dbus-check-event'.
This function signals a `dbus-error' if the event is not well
formed."
(dbus-check-event event)
- (nth 6 event))
+ (nth 7 event))
(defun dbus-event-member-name (event)
"Return the member name the event is coming from.
-It is either a signal name or a method name. The result is a
-string. EVENT is a D-Bus event, see `dbus-check-event'. This
-function signals a `dbus-error' if the event is not well formed."
+It is either a signal name, a method name or an error name. The
+result is a string. EVENT is a D-Bus event, see
+`dbus-check-event'. This function signals a `dbus-error' if the
+event is not well formed."
(dbus-check-event event)
- (nth 7 event))
+ (nth 8 event))
+
+(defun dbus-event-handler (event)
+ "Return the handler the event is applied with.
+The result is a function. EVENT is a D-Bus event, see
+`dbus-check-event'. This function signals a `dbus-error' if the
+event is not well formed."
+ (dbus-check-event event)
+ (nth 9 event))
+
+(defun dbus-event-arguments (event)
+ "Return the arguments the event is carrying on.
+The result is a list of arguments. EVENT is a D-Bus event, see
+`dbus-check-event'. This function signals a `dbus-error' if the
+event is not well formed."
+ (dbus-check-event event)
+ (nthcdr 10 event))
;;; D-Bus registered names.
@@ -1717,7 +1783,7 @@ It will be registered for all objects created by
`dbus-register-property'."
;; "Set" needs the third typed argument from `last-input-event'.
((string-equal method "Set")
- (let* ((value (dbus-flatten-types (nth 11 last-input-event)))
+ (let* ((value (dbus-flatten-types (nth 12 last-input-event)))
(entry (dbus-get-this-registered-property
bus service path interface property))
(object (car (last (car entry)))))
@@ -1907,13 +1973,123 @@ It will be registered for all objects created by
`dbus-register-service'."
result)
'(:signature "{oa{sa{sv}}}"))))))
+(defun dbus-register-monitor
+ (bus &optional service path interface member handler &rest args)
+ "Register HANDLER for monitor events on the D-Bus BUS.
+
+BUS is either a Lisp symbol, `:system' or `:session', or a string
+denoting the bus address.
+
+SERVICE is the D-Bus service name of the D-Bus. It must be a
+known name (see discussion of DONT-REGISTER-SERVICE below).
+
+PATH is the D-Bus object path SERVICE is registered at (see
+discussion of DONT-REGISTER-SERVICE below). INTERFACE is the
+name of the interface used at PATH. MEMBER is either a method
+name, a signal name, or an error name.
+
+HANDLER is the function to be called when a monitor event
+arrives. If nil, the default handler `dbus-monitor-handler' is
+applied. It is called with ARGS as arguments."
+
+ (let ((bus-private (if (eq bus :system) :system-private
+ (if (eq bus :session) :session-private bus)))
+ keyword type rule1 rule2 key key1 value)
+ (unless handler (setq handler #'dbus-monitor-handler))
+ ;; Read arguments.
+ (while args
+ (when (keywordp (setq keyword (pop args)))
+ (cond
+ ((eq :type keyword)
+ ;; Must be "signal", "method_call", "method_return", or "error".
+ (setq type (pop args))))))
+ ;; Compose rules.
+ (setq rule1
+ (or
+ (string-join
+ (delq nil
+ (list (when service (format "sender='%s'" service))
+ (when path (format "path='%s'" path))
+ (when interface (format "interface='%s'" interface))
+ (when member (format "member='%s'" member))
+ (when type (format "type='%s'" type))))
+ ",")
+ "")
+ rule2
+ (when service
+ (string-join
+ (delq nil
+ (list (format "destination='%s'" service)
+ (when path (format "path='%s'" path))
+ (when interface (format "interface='%s'" interface))
+ (when member (format "member='%s'" member))
+ (when type (format "type='%s'" type))))
+ ",")))
+
+ (unless (ignore-errors (dbus-get-unique-name bus-private))
+ (dbus-init-bus bus 'private))
+ (dbus-call-method
+ bus-private dbus-service-dbus dbus-path-dbus dbus-interface-monitoring
+ "BecomeMonitor"
+ (append `(:array :string ,rule1) (when rule2 `(:string ,rule2)))
+ :uint32 0)
+
+ (when dbus-debug (message "Matching rule \"%s\" created" rule1))
+
+ ;; Create a hash table entry.
+ (setq key (list :monitor bus-private)
+ key1 (list nil nil nil handler)
+ value (gethash key dbus-registered-objects-table))
+ (unless (member key1 value)
+ (puthash key (cons key1 value) dbus-registered-objects-table))
+
+ (when dbus-debug (message "%s" dbus-registered-objects-table))
+
+ ;; Return the object.
+ (list key (list service path handler))))
+
+(defun dbus-monitor-handler (&rest _args)
+ "Default handler for the \"org.freedesktop.DBus.Monitoring.BecomeMonitor\"
interface.
+It will be applied all objects created by `dbus-register-monitor'."
+ (with-current-buffer (get-buffer-create "*D-Bus Monitor*")
+ (special-mode)
+ (let* ((inhibit-read-only t)
+ (eobp (eobp))
+ (event last-input-event)
+ (type (dbus-event-message-type event))
+ (sender (dbus-event-service-name event))
+ (destination (dbus-event-destination-name event))
+ (serial (dbus-event-serial-number event))
+ (path (dbus-event-path-name event))
+ (interface (dbus-event-interface-name event))
+ (member (dbus-event-member-name event))
+ (arguments (dbus-event-arguments event)))
+ (save-excursion
+ (goto-char (point-max))
+ (insert
+ (format
+ (concat
+ "%s sender=%s -> destination=%s serial=%s "
+ "path=%s interface=%s member=%s\n")
+ (cond
+ ((= type dbus-message-type-method-call) "method-call")
+ ((= type dbus-message-type-method-return) "method-return")
+ ((= type dbus-message-type-error) "error")
+ ((= type dbus-message-type-signal) "signal"))
+ sender destination serial path interface member))
+ (dolist (arg arguments)
+ (pp (dbus-flatten-types arg) (current-buffer)))
+ (insert "\n"))
+ (when eobp
+ (goto-char (point-max))))))
+
(defun dbus-handle-bus-disconnect ()
"React to a bus disconnection.
BUS is the bus that disconnected. This routine unregisters all
handlers on the given bus and causes all synchronous calls
pending at the time of disconnect to fail."
(let ((bus (dbus-event-bus-name last-input-event))
- (keys-to-remove))
+ keys-to-remove)
(maphash
(lambda (key value)
(when (and (eq (nth 0 key) :serial)
@@ -1923,13 +2099,14 @@ pending at the time of disconnect to fail."
(list 'dbus-event
bus
dbus-message-type-error
- (nth 2 key)
- nil
- nil
- nil
- nil
- value)
- (list 'dbus-error "Bus disconnected" bus))
+ (nth 2 key) ; serial
+ nil ; service
+ nil ; destination
+ nil ; path
+ nil ; interface
+ nil ; member
+ value) ; handler
+ (list 'dbus-error dbus-error-disconnected "Bus disconnected" bus))
(push key keys-to-remove)))
dbus-registered-objects-table)
(dolist (key keys-to-remove)
@@ -1980,13 +2157,9 @@ this connection to those buses."
;;; TODO:
-;; * Check property type in org.freedesktop.DBus.Properties.Set.
-;;
;; * Implement org.freedesktop.DBus.ObjectManager.InterfacesAdded and
;; org.freedesktop.DBus.ObjectManager.InterfacesRemoved.
;;
-;; * Implement org.freedesktop.DBus.Monitoring.BecomeMonitor.
-;;
;; * Cache introspection data.
;;
;; * Run handlers in own threads.
diff --git a/src/dbusbind.c b/src/dbusbind.c
index 4c5ab48..09f0317 100644
--- a/src/dbusbind.c
+++ b/src/dbusbind.c
@@ -44,7 +44,10 @@ along with GNU Emacs. If not, see
<https://www.gnu.org/licenses/>. */
/* Alist of D-Bus buses we are polling for messages.
The key is the symbol or string of the bus, and the value is the
- connection address. */
+ connection address. For every bus, just one connection is counted.
+ If there shall be a second connection to the same bus, a different
+ symbol or string for the bus must be chosen. On Lisp level, a bus
+ stands for the associated connection. */
static Lisp_Object xd_registered_buses;
/* Whether we are reading a D-Bus event. */
@@ -279,10 +282,13 @@ XD_OBJECT_TO_STRING (Lisp_Object object)
else \
{
\
CHECK_SYMBOL (bus); \
- if (!(EQ (bus, QCsystem) || EQ (bus, QCsession))) \
+ if (!(EQ (bus, QCsystem) || EQ (bus, QCsession) \
+ || EQ (bus, QCsystem_private) \
+ || EQ (bus, QCsession_private))) \
XD_SIGNAL2 (build_string ("Wrong bus name"), bus); \
/* We do not want to have an autolaunch for the session bus. */ \
- if (EQ (bus, QCsession) && session_bus_address == NULL) \
+ if ((EQ (bus, QCsession) || EQ (bus, QCsession_private)) \
+ && session_bus_address == NULL) \
XD_SIGNAL2 (build_string ("No connection to bus"), bus); \
}
\
} while (0)
@@ -968,8 +974,9 @@ xd_lisp_dbus_to_dbus (Lisp_Object bus)
return xmint_pointer (bus);
}
-/* Return D-Bus connection address. BUS is either a Lisp symbol,
- :system or :session, or a string denoting the bus address. */
+/* Return D-Bus connection address.
+ BUS is either a Lisp symbol, :system, :session, :system-private or
+ :session-private, or a string denoting the bus address. */
static DBusConnection *
xd_get_connection_address (Lisp_Object bus)
{
@@ -1031,7 +1038,8 @@ xd_add_watch (DBusWatch *watch, void *data)
}
/* Stop monitoring WATCH for possible I/O.
- DATA is the used bus, either a string or QCsystem or QCsession. */
+ DATA is the used bus, either a string or QCsystem, QCsession,
+ QCsystem_private or QCsession_private. */
static void
xd_remove_watch (DBusWatch *watch, void *data)
{
@@ -1046,7 +1054,7 @@ xd_remove_watch (DBusWatch *watch, void *data)
/* Unset session environment. */
#if 0
/* This is buggy, since unsetenv is not thread-safe. */
- if (XSYMBOL (QCsession) == data)
+ if (XSYMBOL (QCsession) == data) || (XSYMBOL (QCsession_private) == data)
{
XD_DEBUG_MESSAGE ("unsetenv DBUS_SESSION_BUS_ADDRESS");
unsetenv ("DBUS_SESSION_BUS_ADDRESS");
@@ -1120,6 +1128,11 @@ can be a string denoting the address of the
corresponding bus. For
the system and session buses, this function is called when loading
`dbus.el', there is no need to call it again.
+A special case is BUS being the symbol `:system-private' or
+`:session-private'. These symbols still denote the system or session
+bus, but using a private connection. They should not be used outside
+dbus.el.
+
The function returns a number, which counts the connections this Emacs
session has established to the BUS under the same unique name (see
`dbus-get-unique-name'). It depends on the libraries Emacs is linked
@@ -1142,6 +1155,10 @@ this connection to those buses. */)
ptrdiff_t refcount;
/* Check parameter. */
+ if (!NILP (private))
+ bus = EQ (bus, QCsystem)
+ ? QCsystem_private
+ : EQ (bus, QCsession) ? QCsession_private : bus;
XD_DBUS_VALIDATE_BUS_ADDRESS (bus);
/* Close bus if it is already open. */
@@ -1169,8 +1186,9 @@ this connection to those buses. */)
else
{
- DBusBusType bustype = (EQ (bus, QCsystem)
- ? DBUS_BUS_SYSTEM : DBUS_BUS_SESSION);
+ DBusBusType bustype
+ = EQ (bus, QCsystem) || EQ (bus, QCsystem_private)
+ ? DBUS_BUS_SYSTEM : DBUS_BUS_SESSION;
if (NILP (private))
connection = dbus_bus_get (bustype, &derror);
else
@@ -1184,9 +1202,9 @@ this connection to those buses. */)
XD_SIGNAL2 (build_string ("No connection to bus"), bus);
/* If it is not the system or session bus, we must register
- ourselves. Otherwise, we have called dbus_bus_get, which has
- configured us to exit if the connection closes - we undo this
- setting. */
+ ourselves. Otherwise, we have called dbus_bus_get{_private},
+ which has configured us to exit if the connection closes - we
+ undo this setting. */
if (STRINGP (bus))
dbus_bus_register (connection, &derror);
else
@@ -1215,6 +1233,9 @@ this connection to those buses. */)
dbus_error_free (&derror);
}
+ XD_DEBUG_MESSAGE ("Registered buses: %s",
+ XD_OBJECT_TO_STRING (xd_registered_buses));
+
/* Return reference counter. */
refcount = xd_get_connection_references (connection);
XD_DEBUG_MESSAGE ("Bus %s, Reference counter %"pD"d",
@@ -1533,8 +1554,8 @@ usage: (dbus-message-internal &rest REST) */)
}
/* Read one queued incoming message of the D-Bus BUS.
- BUS is either a Lisp symbol, :system or :session, or a string denoting
- the bus address. */
+ BUS is either a Lisp symbol, :system, :session, :system-private or
+ :session-private, or a string denoting the bus address. */
static void
xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
{
@@ -1546,7 +1567,7 @@ xd_read_message_1 (DBusConnection *connection,
Lisp_Object bus)
int mtype;
dbus_uint32_t serial;
unsigned int ui_serial;
- const char *uname, *path, *interface, *member, *error_name;
+ const char *uname, *destination, *path, *interface, *member, *error_name;
dmessage = dbus_connection_pop_message (connection);
@@ -1579,6 +1600,7 @@ xd_read_message_1 (DBusConnection *connection,
Lisp_Object bus)
? dbus_message_get_reply_serial (dmessage)
: dbus_message_get_serial (dmessage);
uname = dbus_message_get_sender (dmessage);
+ destination = dbus_message_get_destination (dmessage);
path = dbus_message_get_path (dmessage);
interface = dbus_message_get_interface (dmessage);
member = dbus_message_get_member (dmessage);
@@ -1586,7 +1608,8 @@ xd_read_message_1 (DBusConnection *connection,
Lisp_Object bus)
XD_DEBUG_MESSAGE ("Event received: %s %u %s %s %s %s %s %s",
XD_MESSAGE_TYPE_TO_STRING (mtype),
- ui_serial, uname, path, interface, member, error_name,
+ ui_serial, uname, destination, path, interface,
+ mtype == DBUS_MESSAGE_TYPE_ERROR ? error_name : member,
XD_OBJECT_TO_STRING (args));
if (mtype == DBUS_MESSAGE_TYPE_INVALID)
@@ -1601,7 +1624,7 @@ xd_read_message_1 (DBusConnection *connection,
Lisp_Object bus)
/* There shall be exactly one entry. Construct an event. */
if (NILP (value))
- goto cleanup;
+ goto monitor;
/* Remove the entry. */
Fremhash (key, Vdbus_registered_objects_table);
@@ -1610,11 +1633,8 @@ xd_read_message_1 (DBusConnection *connection,
Lisp_Object bus)
EVENT_INIT (event);
event.kind = DBUS_EVENT;
event.frame_or_window = Qnil;
- event.arg =
- Fcons (value,
- (mtype == DBUS_MESSAGE_TYPE_ERROR)
- ? Fcons (list2 (QCstring, build_string (error_name)), args)
- : args);
+ /* Handler. */
+ event.arg = Fcons (value, args);
}
else /* DBUS_MESSAGE_TYPE_METHOD_CALL, DBUS_MESSAGE_TYPE_SIGNAL. */
@@ -1622,7 +1642,7 @@ xd_read_message_1 (DBusConnection *connection,
Lisp_Object bus)
/* Vdbus_registered_objects_table requires non-nil interface and
member. */
if ((interface == NULL) || (member == NULL))
- goto cleanup;
+ goto monitor;
/* Search for a registered function of the message. */
key = list4 (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL ? QCmethod :
QCsignal,
@@ -1647,6 +1667,7 @@ xd_read_message_1 (DBusConnection *connection,
Lisp_Object bus)
EVENT_INIT (event);
event.kind = DBUS_EVENT;
event.frame_or_window = Qnil;
+ /* Handler. */
event.arg
= Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))), args);
break;
@@ -1655,16 +1676,22 @@ xd_read_message_1 (DBusConnection *connection,
Lisp_Object bus)
}
if (NILP (value))
- goto cleanup;
+ goto monitor;
}
- /* Add type, serial, uname, path, interface and member to the event. */
- event.arg = Fcons ((member == NULL ? Qnil : build_string (member)),
- event.arg);
+ /* Add type, serial, uname, destination, path, interface and member
+ or error_name to the event. */
+ event.arg
+ = Fcons (mtype == DBUS_MESSAGE_TYPE_ERROR
+ ? error_name == NULL ? Qnil : build_string (error_name)
+ : member == NULL ? Qnil : build_string (member),
+ event.arg);
event.arg = Fcons ((interface == NULL ? Qnil : build_string (interface)),
event.arg);
event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
event.arg);
+ event.arg = Fcons ((destination == NULL ? Qnil : build_string (destination)),
+ event.arg);
event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
event.arg);
event.arg = Fcons (INT_TO_INTEGER (serial), event.arg);
@@ -1678,14 +1705,58 @@ xd_read_message_1 (DBusConnection *connection,
Lisp_Object bus)
XD_DEBUG_MESSAGE ("Event stored: %s", XD_OBJECT_TO_STRING (event.arg));
+ /* Monitor. */
+ monitor:
+ /* Search for a registered function of the message. */
+ key = list2 (QCmonitor, bus);
+ value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
+
+ /* There shall be exactly one entry. Construct an event. */
+ if (NILP (value))
+ goto cleanup;
+
+ /* Construct an event. */
+ EVENT_INIT (event);
+ event.kind = DBUS_EVENT;
+ event.frame_or_window = Qnil;
+
+ /* Add type, serial, uname, destination, path, interface, member
+ or error_name and handler to the event. */
+ event.arg
+ = Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (CAR_SAFE (value))))),
+ args);
+ event.arg
+ = Fcons (mtype == DBUS_MESSAGE_TYPE_ERROR
+ ? error_name == NULL ? Qnil : build_string (error_name)
+ : member == NULL ? Qnil : build_string (member),
+ event.arg);
+ event.arg = Fcons ((interface == NULL ? Qnil : build_string (interface)),
+ event.arg);
+ event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
+ event.arg);
+ event.arg = Fcons ((destination == NULL ? Qnil : build_string (destination)),
+ event.arg);
+ event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
+ event.arg);
+ event.arg = Fcons (INT_TO_INTEGER (serial), event.arg);
+ event.arg = Fcons (make_fixnum (mtype), event.arg);
+
+ /* Add the bus symbol to the event. */
+ event.arg = Fcons (bus, event.arg);
+
+ /* Store it into the input event queue. */
+ kbd_buffer_store_event (&event);
+
+ XD_DEBUG_MESSAGE ("Monitor event stored: %s", XD_OBJECT_TO_STRING
(event.arg));
+
/* Cleanup. */
cleanup:
dbus_message_unref (dmessage);
}
/* Read queued incoming messages of the D-Bus BUS.
- BUS is either a Lisp symbol, :system or :session, or a string denoting
- the bus address. */
+ BUS is either a Lisp symbol, :system, :session, :system-private or
+ :session-private, or a string denoting the bus address. */
static Lisp_Object
xd_read_message (Lisp_Object bus)
{
@@ -1762,6 +1833,8 @@ syms_of_dbusbind (void)
/* Lisp symbols of the system and session buses. */
DEFSYM (QCsystem, ":system");
DEFSYM (QCsession, ":session");
+ DEFSYM (QCsystem_private, ":system-private");
+ DEFSYM (QCsession_private, ":session-private");
/* Lisp symbol for method call timeout. */
DEFSYM (QCtimeout, ":timeout");
@@ -1788,10 +1861,11 @@ syms_of_dbusbind (void)
DEFSYM (QCdict_entry, ":dict-entry");
/* Lisp symbols of objects in `dbus-registered-objects-table'.
- `:property', which does exist there as well, is not used here. */
+ `:property', which does exist there as well, is not declared here. */
DEFSYM (QCserial, ":serial");
DEFSYM (QCmethod, ":method");
DEFSYM (QCsignal, ":signal");
+ DEFSYM (QCmonitor, ":monitor");
DEFVAR_LISP ("dbus-compiled-version",
Vdbus_compiled_version,
@@ -1867,8 +1941,9 @@ path of the sending object. All of them can be nil,
which means a
wildcard then.
OBJECT is either the handler to be called when a D-Bus message, which
-matches the key criteria, arrives (TYPE `:method' and `:signal'), or a
-list (ACCESS EMITS-SIGNAL VALUE) for TYPE `:property'.
+matches the key criteria, arrives (TYPE `:method', `:signal' and
+`:monitor'), or a list (ACCESS EMITS-SIGNAL VALUE) for TYPE
+`:property'.
For entries of type `:signal', there is also a fifth element RULE,
which keeps the match string the signal is registered with.