-;;; -*- no-byte-compile: t; -*-
;;; dbus.el --- Elisp bindings for D-Bus.
-;; Copyright (C) 2007 Free Software Foundation, Inc.
+;; Copyright (C) 2007, 2008 Free Software Foundation, Inc.
;; Author: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, hardware
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 3, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, see
-;; <http://www.gnu.org/licenses/>.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
+;; 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-register-signal "dbusbind.c")
+(defvar dbus-debug)
+(defvar dbus-registered-functions-table)
+
+;; Pacify byte compiler.
+(eval-when-compile
+ (require 'cl))
+
(require 'xml)
(defconst dbus-service-dbus "org.freedesktop.DBus"
(defconst dbus-interface-dbus "org.freedesktop.DBus"
"The interface exported by the object with `dbus-service-dbus' and `dbus-path-dbus'.")
-(defconst dbus-interface-introspectable "org.freedesktop.DBus.Introspectable"
+(defconst dbus-interface-peer (concat dbus-interface-dbus ".Peer")
+ "The interface for peer objects.")
+
+(defconst dbus-interface-introspectable
+ (concat dbus-interface-dbus ".Introspectable")
"The interface supported by introspectable objects.")
+(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."
+ `(condition-case err
+ (progn ,@body)
+ (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))
+(font-lock-add-keywords 'emacs-lisp-mode '("\\<dbus-ignore-errors\\>"))
+
\f
;;; Hash table of registered functions.
(setq dbus-registered-functions-table (make-hash-table :test 'equal))
(defun dbus-list-hash-table ()
- "Returns all registered signal registrations to D-Bus.
+ "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
hash table."
dbus-registered-functions-table)
result))
-(defun dbus-name-owner-changed-handler (service old-owner new-owner)
- "Reapplies all signal registrations to D-Bus.
+(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."
+ ;; 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)))
+ ;; 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
+ ;; 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))
+
+(defun dbus-name-owner-changed-handler (&rest args)
+ "Reapplies all member registrations to D-Bus.
This handler is applied when a \"NameOwnerChanged\" signal has
arrived. SERVICE is the object name for which the name owner has
been changed. OLD-OWNER is the previous owner of SERVICE, or the
empty string if SERVICE was not owned yet. NEW-OWNER is the new
-owner of SERVICE, or the empty string if SERVICE looses any name owner."
+owner of SERVICE, or the empty string if SERVICE looses any name owner.
+
+usage: (dbus-name-owner-changed-handler service old-owner new-owner)"
(save-match-data
- ;; Check whether SERVICE is a known name.
- (when (and (stringp service) (not (string-match "^:" service))
- (stringp old-owner) (stringp new-owner))
- (maphash
- '(lambda (key value)
- (dolist (elt value)
- ;; key has the structure (BUS INTERFACE SIGNAL).
- ;; elt has the structure (SERVICE UNAME PATH HANDLER).
- (when (string-equal old-owner (cadr elt))
- ;; Remove old key, and add new entry with changed name.
- (when dbus-debug (message "Remove rule for %s %s" key elt))
- ;(dbus-unregister-signal key)
- (setcar (cdr elt) new-owner)
- (when dbus-debug (message "Add rule for %s %s" key elt))
- ;; Maybe we could arrange the lists a little bit better
- ;; that we don't need to extract every single element?
- (when (not (zerop (length new-owner)))
- (dbus-register-signal
- ;; BUS SERVICE PATH
- (nth 0 key) (nth 0 elt) (nth 2 elt)
- ;; INTERFACE SIGNAL HANDLER
- (nth 1 key) (nth 2 key) (nth 3 elt))))))
- (copy-hash-table dbus-registered-functions-table)))))
+ ;; Check the arguments. We should silently ignore it when they
+ ;; are wrong.
+ (if (and (= (length args) 3)
+ (stringp (car args))
+ (stringp (cadr args))
+ (stringp (caddr args)))
+ (let ((service (car args))
+ (old-owner (cadr args))
+ (new-owner (caddr args)))
+ ;; Check whether SERVICE is a known name.
+ (when (not (string-match "^:" service))
+ (maphash
+ '(lambda (key value)
+ (dolist (elt value)
+ ;; key has the structure (BUS INTERFACE MEMBER).
+ ;; elt has the structure (UNAME SERVICE PATH HANDLER).
+ (when (string-equal old-owner (car elt))
+ ;; Remove old key, and add new entry with changed name.
+ (dbus-unregister-object (list key (cdr elt)))
+ ;; Maybe we could arrange the lists a little bit better
+ ;; that we don't need to extract every single element?
+ (dbus-register-signal
+ ;; BUS SERVICE PATH
+ (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))))
+ ;; The error is reported only in debug mode.
+ (when dbus-debug
+ (signal
+ 'dbus-error
+ (cons
+ (format "Wrong arguments of %s.NameOwnerChanged" dbus-interface-dbus)
+ args))))))
;; Register the handler.
-(condition-case nil
- (progn
- (dbus-register-signal
- :system dbus-service-dbus dbus-path-dbus dbus-interface-dbus
- "NameOwnerChanged" 'dbus-name-owner-changed-handler)
- (dbus-register-signal
- :session dbus-service-dbus dbus-path-dbus dbus-interface-dbus
- "NameOwnerChanged" 'dbus-name-owner-changed-handler))
- (dbus-error))
+(ignore-errors
+ (dbus-register-signal
+ :system dbus-service-dbus dbus-path-dbus dbus-interface-dbus
+ "NameOwnerChanged" 'dbus-name-owner-changed-handler)
+ (dbus-register-signal
+ :session dbus-service-dbus dbus-path-dbus dbus-interface-dbus
+ "NameOwnerChanged" 'dbus-name-owner-changed-handler))
\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 SERVICE PATH INTERFACE MEMBER HANDLER &rest ARGS)
+ (dbus-event BUS SERIAL SERVICE PATH INTERFACE MEMBER HANDLER &rest ARGS)
-BUS identifies the D-Bus the signal is coming from. It is either
-the symbol `:system' or the symbol `:session'. SERVICE and PATH
-are the unique name and the object path of the D-Bus object
-emitting the signal. INTERFACE and MEMBER denote the signal
-which has been sent. HANDLER is the function which has been
-registered for this signal. ARGS are the arguments passed to
-HANDLER, when it is called during event handling in
-`dbus-handle-event'.
+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'.
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))
+ ;; Serial.
+ (or (natnump (nth 2 event)) (null (nth 2 event)))
;; Service.
- (stringp (nth 2 event))
- ;; Object path.
(stringp (nth 3 event))
- ;; Interface.
+ ;; Object path.
(stringp (nth 4 event))
- ;; Member.
+ ;; Interface.
(stringp (nth 5 event))
+ ;; Member.
+ (stringp (nth 6 event))
;; Handler.
- (functionp (nth 6 event)))
+ (functionp (nth 7 event)))
(signal 'dbus-error (list "Not a valid D-Bus event" event))))
;;;###autoload
(interactive "e")
;; We don't want to raise an error, because this function is called
;; in the event handling loop.
- (condition-case nil
- (progn
- (dbus-check-event event)
- (apply (nth 6 event) (nthcdr 7 event)))
- (dbus-error)))
+ (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)))))
(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-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."
+ (dbus-check-event event)
+ (nth 2 event))
+
(defun dbus-event-service-name (event)
"Return the name 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 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-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 3 event))
+ (nth 4 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 4 event))
+ (nth 5 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 5 event))
+ (nth 6 event))
\f
;;; D-Bus registered 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
activatable service names at all."
- (condition-case nil
- (dbus-call-method
- :system dbus-service-dbus
- dbus-path-dbus dbus-interface-dbus "ListActivatableNames")
- (dbus-error)))
+ (dbus-ignore-errors
+ (dbus-call-method
+ :system dbus-service-dbus
+ dbus-path-dbus dbus-interface-dbus "ListActivatableNames")))
(defun dbus-list-names (bus)
"Return the service names registered at D-Bus BUS.
registered service names at all. Well known names are strings like
\"org.freedesktop.DBus\". Names starting with \":\" are unique names
for services."
- (condition-case nil
- (dbus-call-method
- bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "ListNames")
- (dbus-error)))
+ (dbus-ignore-errors
+ (dbus-call-method
+ bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "ListNames")))
(defun dbus-list-known-names (bus)
"Retrieve all services which correspond to a known name in BUS.
"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."
- (condition-case nil
- (dbus-call-method
- bus dbus-service-dbus dbus-path-dbus
- dbus-interface-dbus "ListQueuedOwners" service)
- (dbus-error)))
+ (dbus-ignore-errors
+ (dbus-call-method
+ bus dbus-service-dbus dbus-path-dbus
+ dbus-interface-dbus "ListQueuedOwners" service)))
(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."
+ (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."
+ ;; "Ping" raises a D-Bus error if SERVICE does not exist.
+ ;; Otherwise, it returns silently with `nil'.
(condition-case nil
- (dbus-call-method
- bus dbus-service-dbus dbus-path-dbus
- dbus-interface-dbus "GetNameOwner" service)
- (dbus-error)))
+ (not
+ (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.
\(dbus-introspect
:system \"org.freedesktop.Hal\"
\"/org/freedesktop/Hal/devices/computer\")"
- (condition-case nil
- (dbus-call-method
- bus service path dbus-interface-introspectable "Introspect")
- (dbus-error)))
+ (dbus-ignore-errors
+ (dbus-call-method
+ 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)
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."
- (condition-case nil
- (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 ""))
- ;; 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)
- ;; We ignore `dbus-error'. There might be no introspectable interface.
- (dbus-error nil)))
+ (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 ...
(provide 'dbus)
HCoop / bpt / emacs.git / blobdiff