;;; dbus.el --- Elisp bindings for D-Bus.
-;; Copyright (C) 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Author: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, hardware
;; D-Bus support in the Emacs core can be disabled with configuration
;; option "--without-dbus". Declare used subroutines and variables.
(declare-function dbus-call-method "dbusbind.c")
+(declare-function dbus-call-method-asynchronously "dbusbind.c")
+(declare-function dbus-init-bus "dbusbind.c")
+(declare-function dbus-method-return-internal "dbusbind.c")
+(declare-function dbus-method-error-internal "dbusbind.c")
(declare-function dbus-register-signal "dbusbind.c")
(defvar dbus-debug)
-(defvar dbus-registered-functions-table)
+(defvar dbus-registered-objects-table)
;; Pacify byte compiler.
(eval-when-compile
(concat dbus-interface-dbus ".Introspectable")
"The interface supported by introspectable objects.")
+(defconst dbus-interface-properties (concat dbus-interface-dbus ".Properties")
+ "The interface for property objects.")
+
+(defconst dbus-service-emacs "org.gnu.Emacs"
+ "The well known service name of Emacs.")
+
+(defconst dbus-path-emacs "/org/gnu/Emacs"
+ "The object path head used by Emacs.")
+
+(defconst dbus-message-type-invalid 0
+ "This value is never a valid message type.")
+
+(defconst dbus-message-type-method-call 1
+ "Message type of a method call message.")
+
+(defconst dbus-message-type-method-return 2
+ "Message type of a method return message.")
+
+(defconst dbus-message-type-error 3
+ "Message type of an error reply message.")
+
+(defconst dbus-message-type-signal 4
+ "Message type of a signal message.")
+
(defmacro dbus-ignore-errors (&rest body)
"Execute BODY; signal D-Bus error when `dbus-debug' is non-nil.
Otherwise, return result of last form in BODY, or all other errors."
(dbus-error (when dbus-debug (signal (car err) (cdr err))))))
(put 'dbus-ignore-errors 'lisp-indent-function 0)
-(put 'dbus-ignore-errors 'edebug-form-spec '(form symbolp body))
+(put 'dbus-ignore-errors 'edebug-form-spec '(form body))
(font-lock-add-keywords 'emacs-lisp-mode '("\\<dbus-ignore-errors\\>"))
+(defvar dbus-event-error-hooks nil
+ "Functions to be called when a D-Bus error happens in the event handler.
+Every function must accept two arguments, the event and the error variable
+catched in `condition-case' by `dbus-error'.")
+
\f
;;; Hash table of registered functions.
;; We create it here. So we have a simple test in dbusbind.c, whether
;; the Lisp code has been loaded.
-(setq dbus-registered-functions-table (make-hash-table :test 'equal))
+(setq dbus-registered-objects-table (make-hash-table :test 'equal))
+
+(defvar dbus-return-values-table (make-hash-table :test 'equal)
+ "Hash table for temporary storing arguments of reply messages.
+A key in this hash table is a list (BUS SERIAL). BUS is either the
+symbol `:system' or the symbol `:session'. SERIAL is the serial number
+of the reply message. See `dbus-call-method-non-blocking-handler' and
+`dbus-call-method-non-blocking'.")
(defun dbus-list-hash-table ()
"Returns all registered member registrations to D-Bus.
The return value is a list, with elements of kind (KEY . VALUE).
-See `dbus-registered-functions-table' for a description of the
+See `dbus-registered-objects-table' for a description of the
hash table."
(let (result)
(maphash
'(lambda (key value) (add-to-list 'result (cons key value) 'append))
- dbus-registered-functions-table)
+ dbus-registered-objects-table)
result))
(defun dbus-unregister-object (object)
"Unregister OBJECT from D-Bus.
-OBJECT must be the result of a preceding `dbus-register-method'
-or `dbus-register-signal' call. It returns t if OBJECT has been
-unregistered, nil otherwise."
+OBJECT must be the result of a preceding `dbus-register-method',
+`dbus-register-property' or `dbus-register-signal' call. It
+returns `t' if OBJECT has been unregistered, `nil' otherwise.
+
+When OBJECT identifies the last method or property, which is
+registered for the respective service, Emacs releases its
+association to the service from D-Bus."
;; Check parameter.
(unless (and (consp object) (not (null (car object))) (consp (cdr object)))
(signal 'wrong-type-argument (list 'D-Bus object)))
;; Find the corresponding entry in the hash table.
(let* ((key (car object))
- (value (gethash key dbus-registered-functions-table)))
+ (value (cdr object))
+ (entry (gethash key dbus-registered-objects-table))
+ ret)
+ ;; entry has the structure ((UNAME SERVICE PATH MEMBER) ...).
+ ;; value has the structure ((SERVICE PATH [HANDLER]) ...).
+ ;; MEMBER is either a string (the handler), or a cons cell (a
+ ;; property value). UNAME and property values are not taken into
+ ;; account for comparision.
+
;; Loop over the registered functions.
- (while (consp value)
- ;; (car value) has the structure (UNAME SERVICE PATH HANDLER).
- ;; (cdr object) has the structure ((SERVICE PATH HANDLER) ...).
- (if (not (equal (cdr (car value)) (car (cdr object))))
- (setq value (cdr value))
- ;; Compute new hash value. If it is empty, remove it from
+ (dolist (elt entry)
+ (when (equal
+ (car value)
+ (butlast (cdr elt) (- (length (cdr elt)) (length (car value)))))
+ ;; Compute new hash value. If it is empty, remove it from the
;; hash table.
- (unless
- (puthash
- key
- (delete (car value) (gethash key dbus-registered-functions-table))
- dbus-registered-functions-table)
- (remhash key dbus-registered-functions-table))
- (setq value t)))
- value))
+ (unless (puthash key (delete elt entry) dbus-registered-objects-table)
+ (remhash key dbus-registered-objects-table))
+ (setq ret t)))
+ ;; Check, whether there is still a registered function or property
+ ;; for the given service. If not, unregister the service from the
+ ;; bus.
+ (dolist (elt entry)
+ (let ((service (cadr elt))
+ (bus (car key))
+ found)
+ (maphash
+ (lambda (k v)
+ (dolist (e v)
+ (ignore-errors
+ (when (and (equal bus (car k)) (string-equal service (cadr e)))
+ (setq found t)))))
+ dbus-registered-objects-table)
+ (unless found
+ (dbus-call-method
+ bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
+ "ReleaseName" service))))
+ ;; Return.
+ ret))
+
+(defun dbus-unregister-service (bus service)
+ "Unregister all objects related to SERVICE from D-Bus BUS.
+BUS must be either the symbol `:system' or the symbol `:session'.
+SERVICE must be a known service name."
+ (maphash
+ (lambda (key value)
+ (dolist (elt value)
+ (ignore-errors
+ (when (and (equal bus (car key)) (string-equal service (cadr elt)))
+ (unless
+ (puthash key (delete elt value) dbus-registered-objects-table)
+ (remhash key dbus-registered-objects-table))))))
+ dbus-registered-objects-table)
+ (dbus-call-method
+ bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
+ "ReleaseName" service))
+
+(defun dbus-call-method-non-blocking-handler (&rest args)
+ "Handler for reply messages of asynchronous D-Bus message calls.
+It calls the function stored in `dbus-registered-objects-table'.
+The result will be made available in `dbus-return-values-table'."
+ (puthash (list (dbus-event-bus-name last-input-event)
+ (dbus-event-serial-number last-input-event))
+ (if (= (length args) 1) (car args) args)
+ dbus-return-values-table))
+
+(defun dbus-call-method-non-blocking
+ (bus service path interface method &rest args)
+ "Call METHOD on the D-Bus BUS, but don't block the event queue.
+This is necessary for communicating to registered D-Bus methods,
+which are running in the same Emacs process.
+
+The arguments are the same as in `dbus-call-method'.
+
+usage: (dbus-call-method-non-blocking
+ BUS SERVICE PATH INTERFACE METHOD
+ &optional :timeout TIMEOUT &rest ARGS)"
+
+ (let ((key
+ (apply
+ 'dbus-call-method-asynchronously
+ bus service path interface method
+ 'dbus-call-method-non-blocking-handler args)))
+ ;; Wait until `dbus-call-method-non-blocking-handler' has put the
+ ;; result into `dbus-return-values-table'.
+ (while (eq (gethash key dbus-return-values-table :ignore) :ignore)
+ (read-event nil nil 0.1))
+
+ ;; Cleanup `dbus-return-values-table'. Return the result.
+ (prog1
+ (gethash key dbus-return-values-table nil)
+ (remhash key dbus-return-values-table))))
(defun dbus-name-owner-changed-handler (&rest args)
"Reapplies all member registrations to D-Bus.
(nth 0 key) (nth 1 elt) (nth 2 elt)
;; INTERFACE MEMBER HANDLER
(nth 1 key) (nth 2 key) (nth 3 elt)))))
- (copy-hash-table dbus-registered-functions-table))))
+ (copy-hash-table dbus-registered-objects-table))))
;; The error is reported only in debug mode.
(when dbus-debug
(signal
args))))))
;; Register the handler.
-(ignore-errors
+(when nil ;ignore-errors
(dbus-register-signal
:system dbus-service-dbus dbus-path-dbus dbus-interface-dbus
"NameOwnerChanged" 'dbus-name-owner-changed-handler)
:session dbus-service-dbus dbus-path-dbus dbus-interface-dbus
"NameOwnerChanged" 'dbus-name-owner-changed-handler))
+\f
+;;; D-Bus type conversion.
+
+(defun dbus-string-to-byte-array (string)
+ "Transforms STRING to list (:array :byte c1 :byte c2 ...).
+STRING shall be UTF8 coded."
+ (if (zerop (length string))
+ '(:array :signature "y")
+ (let (result)
+ (dolist (elt (string-to-list string) (append '(:array) result))
+ (setq result (append result (list :byte elt)))))))
+
+(defun dbus-byte-array-to-string (byte-array)
+ "Transforms BYTE-ARRAY into UTF8 coded string.
+BYTE-ARRAY must be a list of structure (c1 c2 ...)."
+ (apply 'string byte-array))
+
+(defun dbus-escape-as-identifier (string)
+ "Escape an arbitrary STRING so it follows the rules for a C identifier.
+The escaped string can be used as object path component, interface element
+component, bus name component or member name in D-Bus.
+
+The escaping consists of replacing all non-alphanumerics, and the
+first character if it's a digit, with an underscore and two
+lower-case hex digits:
+
+ \"0123abc_xyz\\x01\\xff\" -> \"_30123abc_5fxyz_01_ff\"
+
+i.e. similar to URI encoding, but with \"_\" taking the role of \"%\",
+and a smaller allowed set. As a special case, \"\" is escaped to
+\"_\".
+
+Returns the escaped string. Algorithm taken from
+telepathy-glib's `tp-escape-as-identifier'."
+ (if (zerop (length string))
+ "_"
+ (replace-regexp-in-string
+ "^[0-9]\\|[^A-Za-z0-9]"
+ (lambda (x) (format "_%2x" (aref x 0)))
+ string)))
+
+(defun dbus-unescape-from-identifier (string)
+ "Retrieve the original string from the encoded STRING.
+STRING must have been coded with `dbus-escape-as-identifier'"
+ (if (string-equal string "_")
+ ""
+ (replace-regexp-in-string
+ "_.."
+ (lambda (x) (format "%c" (string-to-number (substring x 1) 16)))
+ string)))
+
\f
;;; D-Bus events.
"Checks whether EVENT is a well formed D-Bus event.
EVENT is a list which starts with symbol `dbus-event':
- (dbus-event BUS SERIAL SERVICE PATH INTERFACE MEMBER HANDLER &rest ARGS)
+ (dbus-event BUS TYPE SERIAL SERVICE PATH INTERFACE MEMBER HANDLER &rest ARGS)
BUS identifies the D-Bus the message is coming from. It is
-either the symbol `:system' or the symbol `:session'. SERIAL is
-the serial number of the received D-Bus message if it is a method
-call, or nil. 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 arguments passed to HANDLER, when it is called during
-event handling in `dbus-handle-event'.
+either the symbol `:system' or the symbol `:session'. 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 arguments passed to
+HANDLER, when it is called during event handling in
+`dbus-handle-event'.
This function raises a `dbus-error' signal in case the event is
not well formed."
(eq (car event) 'dbus-event)
;; Bus symbol.
(symbolp (nth 1 event))
+ ;; Type.
+ (and (natnump (nth 2 event))
+ (< dbus-message-type-invalid (nth 2 event)))
;; Serial.
- (or (natnump (nth 2 event)) (null (nth 2 event)))
+ (natnump (nth 3 event))
;; Service.
- (stringp (nth 3 event))
+ (or (= dbus-message-type-method-return (nth 2 event))
+ (= dbus-message-type-error (nth 2 event))
+ (stringp (nth 4 event)))
;; Object path.
- (stringp (nth 4 event))
+ (or (= dbus-message-type-method-return (nth 2 event))
+ (= dbus-message-type-error (nth 2 event))
+ (stringp (nth 5 event)))
;; Interface.
- (stringp (nth 5 event))
+ (or (= dbus-message-type-method-return (nth 2 event))
+ (= dbus-message-type-error (nth 2 event))
+ (stringp (nth 6 event)))
;; Member.
- (stringp (nth 6 event))
+ (or (= dbus-message-type-method-return (nth 2 event))
+ (= dbus-message-type-error (nth 2 event))
+ (stringp (nth 7 event)))
;; Handler.
- (functionp (nth 7 event)))
+ (functionp (nth 8 event)))
(signal 'dbus-error (list "Not a valid D-Bus event" event))))
;;;###autoload
(defun dbus-handle-event (event)
"Handle events from the D-Bus.
EVENT is a D-Bus event, see `dbus-check-event'. HANDLER, being
-part of the event, is called with arguments ARGS."
+part of the event, is called with arguments ARGS.
+If the HANDLER returns an `dbus-error', it is propagated as return message."
(interactive "e")
- ;; We don't want to raise an error, because this function is called
- ;; in the event handling loop.
- (dbus-ignore-errors
- (let (result)
- (dbus-check-event event)
- (setq result (apply (nth 7 event) (nthcdr 8 event)))
- (unless (consp result) (setq result (cons result nil)))
- ;; Return a message when serial is not nil.
- (when (not (null (nth 2 event)))
- (apply 'dbus-method-return-internal
- (nth 1 event) (nth 2 event) (nth 3 event) result)))))
+ (condition-case err
+ (let (result)
+ ;; We ignore not well-formed events.
+ (dbus-check-event event)
+ ;; Error messages must be propagated.
+ (when (= dbus-message-type-error (nth 2 event))
+ (signal 'dbus-error (nthcdr 9 event)))
+ ;; Apply the handler.
+ (setq result (apply (nth 8 event) (nthcdr 9 event)))
+ ;; Return a message when it is a message call.
+ (when (= dbus-message-type-method-call (nth 2 event))
+ (dbus-ignore-errors
+ (if (eq result :ignore)
+ (dbus-method-return-internal
+ (nth 1 event) (nth 3 event) (nth 4 event))
+ (apply 'dbus-method-return-internal
+ (nth 1 event) (nth 3 event) (nth 4 event)
+ (if (consp result) result (list result)))))))
+ ;; Error handling.
+ (dbus-error
+ ;; Return an error message when it is a message call.
+ (when (= dbus-message-type-method-call (nth 2 event))
+ (dbus-ignore-errors
+ (dbus-method-error-internal
+ (nth 1 event) (nth 3 event) (nth 4 event) (cadr err))))
+ ;; Propagate D-Bus error messages.
+ (run-hook-with-args 'dbus-event-error-hooks event err)
+ (when (or dbus-debug (= dbus-message-type-error (nth 2 event)))
+ (signal (car err) (cdr err))))))
(defun dbus-event-bus-name (event)
"Return the bus name the event is coming from.
(dbus-check-event event)
(nth 1 event))
+(defun dbus-event-message-type (event)
+ "Return the message type of the corresponding D-Bus message.
+The result is a number. EVENT is a D-Bus event, see
+`dbus-check-event'. This function raises a `dbus-error' signal
+in case the event is not well formed."
+ (dbus-check-event event)
+ (nth 2 event))
+
(defun dbus-event-serial-number (event)
"Return the serial number of the corresponding D-Bus message.
-The result is a number in case the D-Bus message is a method
-call, or nil for all other mesage types. The serial number is
-needed for generating a reply message. EVENT is a D-Bus event,
-see `dbus-check-event'. This function raises a `dbus-error'
-signal in case the event is not well formed."
+The result is a number. The serial number is needed for
+generating a reply message. EVENT is a D-Bus event, see
+`dbus-check-event'. This function raises a `dbus-error' signal
+in case the event is not well formed."
(dbus-check-event event)
- (nth 2 event))
+ (nth 3 event))
(defun dbus-event-service-name (event)
"Return the name of the D-Bus object the event is coming from.
This function raises a `dbus-error' signal in case the event is
not well formed."
(dbus-check-event event)
- (nth 3 event))
+ (nth 4 event))
(defun dbus-event-path-name (event)
"Return the object path of the D-Bus object the event is coming from.
This function raises a `dbus-error' signal in case the event is
not well formed."
(dbus-check-event event)
- (nth 4 event))
+ (nth 5 event))
(defun dbus-event-interface-name (event)
"Return the interface name of the D-Bus object the event is coming from.
This function raises a `dbus-error' signal in case the event is
not well formed."
(dbus-check-event event)
- (nth 5 event))
+ (nth 6 event))
(defun dbus-event-member-name (event)
"Return the member name the event is coming from.
function raises a `dbus-error' signal in case the event is not
well formed."
(dbus-check-event event)
- (nth 6 event))
+ (nth 7 event))
\f
;;; D-Bus registered names.
(defun dbus-list-activatable-names ()
"Return the D-Bus service names which can be activated as list.
-The result is a list of strings, which is nil when there are no
+The result is a list of strings, which is `nil' when there are no
activatable service names at all."
(dbus-ignore-errors
(dbus-call-method
(defun dbus-list-names (bus)
"Return the service names registered at D-Bus BUS.
-The result is a list of strings, which is nil when there are no
-registered service names at all. Well known names are strings like
-\"org.freedesktop.DBus\". Names starting with \":\" are unique names
-for services."
+The result is a list of strings, which is `nil' when there are no
+registered service names at all. Well known names are strings
+like \"org.freedesktop.DBus\". Names starting with \":\" are
+unique names for services."
(dbus-ignore-errors
(dbus-call-method
bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "ListNames")))
(add-to-list 'result name 'append)))))
(defun dbus-list-queued-owners (bus service)
-"Return the unique names registered at D-Bus BUS and queued for SERVICE.
-The result is a list of strings, or nil when there are no queued name
-owners service names at all."
+ "Return the unique names registered at D-Bus BUS and queued for SERVICE.
+The result is a list of strings, or `nil' when there are no
+queued name owners service names at all."
(dbus-ignore-errors
(dbus-call-method
bus dbus-service-dbus dbus-path-dbus
(defun dbus-get-name-owner (bus service)
"Return the name owner of SERVICE registered at D-Bus BUS.
-The result is either a string, or nil if there is no name owner."
+The result is either a string, or `nil' if there is no name owner."
(dbus-ignore-errors
(dbus-call-method
bus dbus-service-dbus dbus-path-dbus
dbus-interface-dbus "GetNameOwner" service)))
-(defun dbus-ping (bus service)
- "Check whether SERVICE is registered for D-Bus BUS."
+(defun dbus-ping (bus service &optional timeout)
+ "Check whether SERVICE is registered for D-Bus BUS.
+TIMEOUT, a nonnegative integer, specifies the maximum number of
+milliseconds `dbus-ping' must return. The default value is 25,000.
+
+Note, that this autoloads SERVICE if it is not running yet. If
+it shall be checked whether SERVICE is already running, one shall
+apply
+
+ \(member service \(dbus-list-known-names bus))"
;; "Ping" raises a D-Bus error if SERVICE does not exist.
;; Otherwise, it returns silently with `nil'.
(condition-case nil
(not
- (dbus-call-method bus service dbus-path-dbus dbus-interface-peer "Ping"))
+ (if (natnump timeout)
+ (dbus-call-method
+ bus service dbus-path-dbus dbus-interface-peer
+ "Ping" :timeout timeout)
+ (dbus-call-method
+ bus service dbus-path-dbus dbus-interface-peer "Ping")))
(dbus-error nil)))
-(defun dbus-introspect (bus service path)
- "Return the introspection data of SERVICE in D-Bus BUS at object path PATH.
-The data are in XML format.
-
-Example:
+\f
+;;; D-Bus introspection.
-\(dbus-introspect
- :system \"org.freedesktop.Hal\"
- \"/org/freedesktop/Hal/devices/computer\")"
+(defun dbus-introspect (bus service path)
+ "This function returns all interfaces and sub-nodes of SERVICE,
+registered at object path PATH at bus BUS.
+
+BUS must be either the symbol `:system' or the symbol `:session'.
+SERVICE must be a known service name, and PATH must be a valid
+object path. The last two parameters are strings. The result,
+the introspection data, is a string in XML format."
+ ;; We don't want to raise errors. `dbus-call-method-non-blocking'
+ ;; is used, because the handler can be registered in our Emacs
+ ;; instance; caller an callee would block each other.
(dbus-ignore-errors
- (dbus-call-method
+ (dbus-call-method-non-blocking
bus service path dbus-interface-introspectable "Introspect")))
-(if nil ;; Must be reworked. Shall we offer D-Bus signatures at all?
-(defun dbus-get-signatures (bus interface signal)
- "Retrieve SIGNAL's type signatures from D-Bus.
-The result is a list of SIGNAL's type signatures. Example:
-
- \(\"s\" \"b\" \"ai\"\)
+(defun dbus-introspect-xml (bus service path)
+ "Return the introspection data of SERVICE in D-Bus BUS at object path PATH.
+The data are a parsed list. The root object is a \"node\",
+representing the object path PATH. The root object can contain
+\"interface\" and further \"node\" objects."
+ ;; We don't want to raise errors.
+ (xml-node-name
+ (ignore-errors
+ (with-temp-buffer
+ (insert (dbus-introspect bus service path))
+ (xml-parse-region (point-min) (point-max))))))
+
+(defun dbus-introspect-get-attribute (object attribute)
+ "Return the ATTRIBUTE value of D-Bus introspection OBJECT.
+ATTRIBUTE must be a string according to the attribute names in
+the D-Bus specification."
+ (xml-get-attribute-or-nil object (intern attribute)))
+
+(defun dbus-introspect-get-node-names (bus service path)
+ "Return all node names of SERVICE in D-Bus BUS at object path PATH.
+It returns a list of strings. The node names stand for further
+object paths of the D-Bus service."
+ (let ((object (dbus-introspect-xml bus service path))
+ result)
+ (dolist (elt (xml-get-children object 'node) result)
+ (add-to-list
+ 'result (dbus-introspect-get-attribute elt "name") 'append))))
+
+(defun dbus-introspect-get-all-nodes (bus service path)
+ "Return all node names of SERVICE in D-Bus BUS at object path PATH.
+It returns a list of strings, which are further object paths of SERVICE."
+ (let ((result (list path)))
+ (dolist (elt
+ (dbus-introspect-get-node-names bus service path)
+ result)
+ (setq elt (expand-file-name elt path))
+ (setq result
+ (append result (dbus-introspect-get-all-nodes bus service elt))))))
+
+(defun dbus-introspect-get-interface-names (bus service path)
+ "Return all interface names of SERVICE in D-Bus BUS at object path PATH.
+It returns a list of strings.
+
+There will be always the default interface
+\"org.freedesktop.DBus.Introspectable\". Another default
+interface is \"org.freedesktop.DBus.Properties\". If present,
+\"interface\" objects can also have \"property\" objects as
+children, beside \"method\" and \"signal\" objects."
+ (let ((object (dbus-introspect-xml bus service path))
+ result)
+ (dolist (elt (xml-get-children object 'interface) result)
+ (add-to-list
+ 'result (dbus-introspect-get-attribute elt "name") 'append))))
+
+(defun dbus-introspect-get-interface (bus service path interface)
+ "Return the INTERFACE of SERVICE in D-Bus BUS at object path PATH.
+The return value is an XML object. INTERFACE must be a string,
+element of the list returned by
+`dbus-introspect-get-interface-names'. The resulting
+\"interface\" object can contain \"method\", \"signal\",
+\"property\" and \"annotation\" children."
+ (let ((elt (xml-get-children
+ (dbus-introspect-xml bus service path) 'interface)))
+ (while (and elt
+ (not (string-equal
+ interface
+ (dbus-introspect-get-attribute (car elt) "name"))))
+ (setq elt (cdr elt)))
+ (car elt)))
+
+(defun dbus-introspect-get-method-names (bus service path interface)
+ "Return a list of strings of all method names of INTERFACE.
+SERVICE is a service of D-Bus BUS at object path PATH."
+ (let ((object (dbus-introspect-get-interface bus service path interface))
+ result)
+ (dolist (elt (xml-get-children object 'method) result)
+ (add-to-list
+ 'result (dbus-introspect-get-attribute elt "name") 'append))))
+
+(defun dbus-introspect-get-method (bus service path interface method)
+ "Return method METHOD of interface INTERFACE as XML object.
+It must be located at SERVICE in D-Bus BUS at object path PATH.
+METHOD must be a string, element of the list returned by
+`dbus-introspect-get-method-names'. The resulting \"method\"
+object can contain \"arg\" and \"annotation\" children."
+ (let ((elt (xml-get-children
+ (dbus-introspect-get-interface bus service path interface)
+ 'method)))
+ (while (and elt
+ (not (string-equal
+ method (dbus-introspect-get-attribute (car elt) "name"))))
+ (setq elt (cdr elt)))
+ (car elt)))
+
+(defun dbus-introspect-get-signal-names (bus service path interface)
+ "Return a list of strings of all signal names of INTERFACE.
+SERVICE is a service of D-Bus BUS at object path PATH."
+ (let ((object (dbus-introspect-get-interface bus service path interface))
+ result)
+ (dolist (elt (xml-get-children object 'signal) result)
+ (add-to-list
+ 'result (dbus-introspect-get-attribute elt "name") 'append))))
+
+(defun dbus-introspect-get-signal (bus service path interface signal)
+ "Return signal SIGNAL of interface INTERFACE as XML object.
+It must be located at SERVICE in D-Bus BUS at object path PATH.
+SIGNAL must be a string, element of the list returned by
+`dbus-introspect-get-signal-names'. The resulting \"signal\"
+object can contain \"arg\" and \"annotation\" children."
+ (let ((elt (xml-get-children
+ (dbus-introspect-get-interface bus service path interface)
+ 'signal)))
+ (while (and elt
+ (not (string-equal
+ signal (dbus-introspect-get-attribute (car elt) "name"))))
+ (setq elt (cdr elt)))
+ (car elt)))
+
+(defun dbus-introspect-get-property-names (bus service path interface)
+ "Return a list of strings of all property names of INTERFACE.
+SERVICE is a service of D-Bus BUS at object path PATH."
+ (let ((object (dbus-introspect-get-interface bus service path interface))
+ result)
+ (dolist (elt (xml-get-children object 'property) result)
+ (add-to-list
+ 'result (dbus-introspect-get-attribute elt "name") 'append))))
+
+(defun dbus-introspect-get-property (bus service path interface property)
+ "This function returns PROPERTY of INTERFACE as XML object.
+It must be located at SERVICE in D-Bus BUS at object path PATH.
+PROPERTY must be a string, element of the list returned by
+`dbus-introspect-get-property-names'. The resulting PROPERTY
+object can contain \"annotation\" children."
+ (let ((elt (xml-get-children
+ (dbus-introspect-get-interface bus service path interface)
+ 'property)))
+ (while (and elt
+ (not (string-equal
+ property
+ (dbus-introspect-get-attribute (car elt) "name"))))
+ (setq elt (cdr elt)))
+ (car elt)))
+
+(defun dbus-introspect-get-annotation-names
+ (bus service path interface &optional name)
+ "Return all annotation names as list of strings.
+If NAME is `nil', the annotations are children of INTERFACE,
+otherwise NAME must be a \"method\", \"signal\", or \"property\"
+object, where the annotations belong to."
+ (let ((object
+ (if name
+ (or (dbus-introspect-get-method bus service path interface name)
+ (dbus-introspect-get-signal bus service path interface name)
+ (dbus-introspect-get-property bus service path interface name))
+ (dbus-introspect-get-interface bus service path interface)))
+ result)
+ (dolist (elt (xml-get-children object 'annotation) result)
+ (add-to-list
+ 'result (dbus-introspect-get-attribute elt "name") 'append))))
+
+(defun dbus-introspect-get-annotation
+ (bus service path interface name annotation)
+ "Return ANNOTATION as XML object.
+If NAME is `nil', ANNOTATION is a child of INTERFACE, otherwise
+NAME must be the name of a \"method\", \"signal\", or
+\"property\" object, where the ANNOTATION belongs to."
+ (let ((elt (xml-get-children
+ (if name
+ (or (dbus-introspect-get-method
+ bus service path interface name)
+ (dbus-introspect-get-signal
+ bus service path interface name)
+ (dbus-introspect-get-property
+ bus service path interface name))
+ (dbus-introspect-get-interface bus service path interface))
+ 'annotation)))
+ (while (and elt
+ (not (string-equal
+ annotation
+ (dbus-introspect-get-attribute (car elt) "name"))))
+ (setq elt (cdr elt)))
+ (car elt)))
+
+(defun dbus-introspect-get-argument-names (bus service path interface name)
+ "Return a list of all argument names as list of strings.
+NAME must be a \"method\" or \"signal\" object.
+
+Argument names are optional, the function can return `nil'
+therefore, even if the method or signal has arguments."
+ (let ((object
+ (or (dbus-introspect-get-method bus service path interface name)
+ (dbus-introspect-get-signal bus service path interface name)))
+ result)
+ (dolist (elt (xml-get-children object 'arg) result)
+ (add-to-list
+ 'result (dbus-introspect-get-attribute elt "name") 'append))))
+
+(defun dbus-introspect-get-argument (bus service path interface name arg)
+ "Return argument ARG as XML object.
+NAME must be a \"method\" or \"signal\" object. ARG must be a
+string, element of the list returned by `dbus-introspect-get-argument-names'."
+ (let ((elt (xml-get-children
+ (or (dbus-introspect-get-method bus service path interface name)
+ (dbus-introspect-get-signal bus service path interface name))
+ 'arg)))
+ (while (and elt
+ (not (string-equal
+ arg (dbus-introspect-get-attribute (car elt) "name"))))
+ (setq elt (cdr elt)))
+ (car elt)))
+
+(defun dbus-introspect-get-signature
+ (bus service path interface name &optional direction)
+ "Return signature of a `method' or `signal', represented by NAME, as string.
+If NAME is a `method', DIRECTION can be either \"in\" or \"out\".
+If DIRECTION is `nil', \"in\" is assumed.
+
+If NAME is a `signal', and DIRECTION is non-`nil', DIRECTION must
+be \"out\"."
+ ;; For methods, we use "in" as default direction.
+ (let ((object (or (dbus-introspect-get-method
+ bus service path interface name)
+ (dbus-introspect-get-signal
+ bus service path interface name))))
+ (when (and (string-equal
+ "method" (dbus-introspect-get-attribute object "name"))
+ (not (stringp direction)))
+ (setq direction "in"))
+ ;; In signals, no direction is given.
+ (when (string-equal "signal" (dbus-introspect-get-attribute object "name"))
+ (setq direction nil))
+ ;; Collect the signatures.
+ (mapconcat
+ '(lambda (x)
+ (let ((arg (dbus-introspect-get-argument
+ bus service path interface name x)))
+ (if (or (not (stringp direction))
+ (string-equal
+ direction
+ (dbus-introspect-get-attribute arg "direction")))
+ (dbus-introspect-get-attribute arg "type")
+ "")))
+ (dbus-introspect-get-argument-names bus service path interface name)
+ "")))
-This list represents 3 parameters of SIGNAL. The first parameter
-is of type string, the second parameter is of type boolean, and
-the third parameter is of type array of integer.
+\f
+;;; D-Bus properties.
-If INTERFACE or SIGNAL do not exist, or if they do not support
-the D-Bus method org.freedesktop.DBus.Introspectable.Introspect,
-the function returns nil."
+(defun dbus-get-property (bus service path interface property)
+ "Return the value of PROPERTY of INTERFACE.
+It will be checked at BUS, SERVICE, PATH. The result can be any
+valid D-Bus value, or `nil' if there is no PROPERTY."
+ (dbus-ignore-errors
+ ;; "Get" returns a variant, so we must use the `car'.
+ (car
+ (dbus-call-method-non-blocking
+ bus service path dbus-interface-properties
+ "Get" :timeout 500 interface property))))
+
+(defun dbus-set-property (bus service path interface property value)
+ "Set value of PROPERTY of INTERFACE to VALUE.
+It will be checked at BUS, SERVICE, PATH. When the value has
+been set successful, the result is VALUE. Otherwise, `nil' is
+returned."
+ (dbus-ignore-errors
+ ;; "Set" requires a variant.
+ (dbus-call-method-non-blocking
+ bus service path dbus-interface-properties
+ "Set" :timeout 500 interface property (list :variant value))
+ ;; Return VALUE.
+ (dbus-get-property bus service path interface property)))
+
+(defun dbus-get-all-properties (bus service path interface)
+ "Return all properties of INTERFACE at BUS, SERVICE, PATH.
+The result is a list of entries. Every entry is a cons of the
+name of the property, and its value. If there are no properties,
+`nil' is returned."
+ (dbus-ignore-errors
+ ;; "GetAll" returns "a{sv}".
+ (let (result)
+ (dolist (dict
+ (dbus-call-method-non-blocking
+ bus service path dbus-interface-properties
+ "GetAll" :timeout 500 interface)
+ result)
+ (add-to-list 'result (cons (car dict) (caadr dict)) 'append)))))
+
+(defun dbus-register-property
+ (bus service path interface property access value)
+ "Register property PROPERTY on the D-Bus BUS.
+
+BUS is either the symbol `:system' or the symbol `:session'.
+
+SERVICE is the D-Bus service name of the D-Bus. It must be a
+known name.
+
+PATH is the D-Bus object path SERVICE is registered. INTERFACE
+is the name of the interface used at PATH, PROPERTY is the name
+of the property of INTERFACE. ACCESS indicates, whether the
+property can be changed by other services via D-Bus. It must be
+either the symbol `:read' or `:readwrite'. VALUE is the initial
+value of the property, it can be of any valid type (see
+`dbus-call-method' for details).
+
+If PROPERTY already exists on PATH, it will be overwritten. For
+properties with access type `:read' this is the only way to
+change their values. Properties with access type `:readwrite'
+can be changed by `dbus-set-property'.
+
+The interface \"org.freedesktop.DBus.Properties\" is added to
+PATH, including a default handler for the \"Get\", \"GetAll\" and
+\"Set\" methods of this interface."
+ (unless (member access '(:read :readwrite))
+ (signal 'dbus-error (list "Access type invalid" access)))
+
+ ;; Register SERVICE.
+ (unless (member service (dbus-list-names bus))
+ (dbus-call-method
+ bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
+ "RequestName" service 0))
+
+ ;; Add the handler. We use `dbus-service-emacs' as service name, in
+ ;; order to let unregister SERVICE despite of this default handler.
+ (dbus-register-method
+ bus service path dbus-interface-properties "Get" 'dbus-property-handler)
+ (dbus-register-method
+ bus service path dbus-interface-properties "GetAll" 'dbus-property-handler)
+ (dbus-register-method
+ bus service path dbus-interface-properties "Set" 'dbus-property-handler)
+
+ ;; Create a hash table entry. We use nil for the unique name,
+ ;; because the property might be accessed from anybody.
+ (let ((key (list bus interface property))
+ (val (list (list nil service path (cons access value)))))
+ (puthash key val dbus-registered-objects-table)
+
+ ;; Return the object.
+ (list key (list service path))))
+
+(defun dbus-property-handler (&rest args)
+ "Default Handler for the \"org.freedesktop.DBus.Properties\" interface.
+It will be registered for all objects created by `dbus-register-object'."
+ (let ((bus (dbus-event-bus-name last-input-event))
+ (path (dbus-event-path-name last-input-event))
+ (method (dbus-event-member-name last-input-event))
+ (interface (car args))
+ (property (cadr args)))
+ (cond
+ ;; "Get" returns a variant.
+ ((string-equal method "Get")
+ (let ((val (gethash (list bus interface property)
+ dbus-registered-objects-table)))
+ (when (string-equal path (nth 2 (car val)))
+ (list (list :variant (cdar (last (car val))))))))
+
+ ;; "Set" expects a variant.
+ ((string-equal method "Set")
+ (let ((val (gethash (list bus interface property)
+ dbus-registered-objects-table)))
+ (unless (consp (car (last (car val))))
+ (signal 'dbus-error
+ (list "Property not registered at path" property path)))
+ (unless (equal (caar (last (car val))) :readwrite)
+ (signal 'dbus-error
+ (list "Property not writable at path" property path)))
+ (puthash (list bus interface property)
+ (list (append (butlast (car val))
+ (list (cons :readwrite (caar (cddr args))))))
+ dbus-registered-objects-table)
+ :ignore))
+
+ ;; "GetAll" returns "a{sv}".
+ ((string-equal method "GetAll")
+ (let (result)
+ (maphash
+ (lambda (key val)
+ (when (and (equal (butlast key) (list bus interface))
+ (string-equal path (nth 2 (car val)))
+ (not (functionp (car (last (car val))))))
+ (add-to-list
+ 'result
+ (list :dict-entry
+ (car (last key))
+ (list :variant (cdar (last (car val))))))))
+ dbus-registered-objects-table)
+ (list result))))))
+
+ \f
+;; Initialize :system and :session buses. This adds their file
+;; descriptors to input_wait_mask, in order to detect incoming
+;; messages immediately.
+(when (featurep 'dbusbind)
(dbus-ignore-errors
- (let ((introspect-xml
- (with-temp-buffer
- (insert (dbus-introspect bus interface))
- (xml-parse-region (point-min) (point-max))))
- node interfaces signals args result)
- ;; Get the root node.
- (setq node (xml-node-name introspect-xml))
- ;; Get all interfaces.
- (setq interfaces (xml-get-children node 'interface))
- (while interfaces
- (when (string-equal (xml-get-attribute (car interfaces) 'name)
- interface)
- ;; That's the requested interface. Check for signals.
- (setq signals (xml-get-children (car interfaces) 'signal))
- (while signals
- (when (string-equal (xml-get-attribute (car signals) 'name) signal)
- ;; The signal we are looking for.
- (setq args (xml-get-children (car signals) 'arg))
- (while args
- (unless (xml-get-attribute (car args) 'type)
- ;; This shouldn't happen, let's escape.
- (signal 'dbus-error nil))
- ;; We append the signature.
- (setq
- result (append result
- (list (xml-get-attribute (car args) 'type))))
- (setq args (cdr args)))
- (setq signals nil))
- (setq signals (cdr signals)))
- (setq interfaces nil))
- (setq interfaces (cdr interfaces)))
- result)))
-) ;; (if nil ...
+ (dbus-init-bus :system)
+ (dbus-init-bus :session)))
(provide 'dbus)