mirror of
git://git.sv.gnu.org/emacs.git
synced 2025-12-15 10:30:25 -08:00
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.
This commit is contained in:
Michael Albinus
parent
c98c7def04
commit
c540f3323d
2 changed files with 341 additions and 93 deletions
295
lisp/net/dbus.el
295
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))))
|
||||
;; Destination.
|
||||
(or (= dbus-message-type-method-return (nth 2 event))
|
||||
(= dbus-message-type-error (nth 2 event))
|
||||
(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 5 event)))
|
||||
(stringp (nth 6 event)))
|
||||
;; Interface.
|
||||
(or (= dbus-message-type-method-return (nth 2 event))
|
||||
(= dbus-message-type-error (nth 2 event))
|
||||
(stringp (nth 6 event)))
|
||||
(stringp (nth 7 event)))
|
||||
;; Member.
|
||||
(or (= dbus-message-type-method-return (nth 2 event))
|
||||
(= dbus-message-type-error (nth 2 event))
|
||||
(stringp (nth 7 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.
|
||||
|
|
|
|||
139
src/dbusbind.c
139
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.
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue