lisp/net/dbus.el

   1 ;;; -*- no-byte-compile: t; -*-
   2 ;;; dbus.el --- Elisp bindings for D-Bus.
   3
   4 ;; Copyright (C) 2007 Free Software Foundation, Inc.
   5
   6 ;; Author: Michael Albinus <michael.albinus@gmx.de>
   7 ;; Keywords: comm, hardware
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 3, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, see
  23 ;; <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; This package provides language bindings for the D-Bus API.  D-Bus
  28 ;; is a message bus system, a simple way for applications to talk to
  29 ;; one another.  See <http://dbus.freedesktop.org/> for details.
  30
  31 ;; Low-level language bindings are implemented in src/dbusbind.c.
  32
  33 ;;; Code:
  34
  35 (require 'xml)
  36
  37 (defconst dbus-service-dbus "org.freedesktop.DBus"
  38   "The bus name used to talk to the bus itself.")
  39
  40 (defconst dbus-path-dbus "/org/freedesktop/DBus"
  41   "The object path used to talk to the bus itself.")
  42
  43 (defconst dbus-interface-dbus "org.freedesktop.DBus"
  44   "The interface exported by the object with `dbus-service-dbus' and `dbus-path-dbus'.")
  45
  46 (defconst dbus-interface-introspectable "org.freedesktop.DBus.Introspectable"
  47   "The interface supported by introspectable objects.")
  48
  49 \f
  50 ;;; Hash table of registered functions.
  51
  52 ;; We create it here.  So we have a simple test in dbusbind.c, whether
  53 ;; the Lisp code has been loaded.
  54 (setq dbus-registered-functions-table (make-hash-table :test 'equal))
  55
  56 (defun dbus-list-hash-table ()
  57   "Returns all registered signal registrations to D-Bus.
  58 The return value is a list, with elements of kind (KEY . VALUE).
  59 See `dbus-registered-functions-table' for a description of the
  60 hash table."
  61   (let (result)
  62     (maphash
  63      '(lambda (key value) (add-to-list 'result (cons key value) 'append))
  64      dbus-registered-functions-table)
  65     result))
  66
  67 (defun dbus-name-owner-changed-handler (service old-owner new-owner)
  68   "Reapplies all signal registrations to D-Bus.
  69 This handler is applied when a \"NameOwnerChanged\" signal has
  70 arrived.  SERVICE is the object name for which the name owner has
  71 been changed.  OLD-OWNER is the previous owner of SERVICE, or the
  72 empty string if SERVICE was not owned yet.  NEW-OWNER is the new
  73 owner of SERVICE, or the empty string if SERVICE looses any name owner."
  74   (save-match-data
  75     ;; Check whether SERVICE is a known name.
  76     (when (and (stringp service) (not (string-match "^:" service))
  77                (stringp old-owner) (stringp new-owner))
  78       (maphash
  79        '(lambda (key value)
  80           (dolist (elt value)
  81             ;; key has the structure (BUS INTERFACE SIGNAL).
  82             ;; elt has the structure (SERVICE UNAME PATH HANDLER).
  83             (when (string-equal old-owner (cadr elt))
  84               ;; Remove old key, and add new entry with changed name.
  85               (when dbus-debug (message "Remove rule for %s %s" key elt))
  86               ;(dbus-unregister-signal key)
  87               (setcar (cdr elt) new-owner)
  88               (when dbus-debug (message "Add rule for %s %s" key elt))
  89               ;; Maybe we could arrange the lists a little bit better
  90               ;; that we don't need to extract every single element?
  91               (when (not (zerop (length new-owner)))
  92                 (dbus-register-signal
  93                  ;; BUS      SERVICE     PATH
  94                  (nth 0 key) (nth 0 elt) (nth 2 elt)
  95                  ;; INTERFACE SIGNAL     HANDLER
  96                  (nth 1 key) (nth 2 key) (nth 3 elt))))))
  97        (copy-hash-table dbus-registered-functions-table)))))
  98
  99 ;; Register the handler.
 100 (condition-case nil
 101     (progn
 102       (dbus-register-signal
 103        :system dbus-service-dbus dbus-path-dbus dbus-interface-dbus
 104        "NameOwnerChanged" 'dbus-name-owner-changed-handler)
 105       (dbus-register-signal
 106        :session dbus-service-dbus dbus-path-dbus dbus-interface-dbus
 107        "NameOwnerChanged" 'dbus-name-owner-changed-handler))
 108   (dbus-error))
 109
 110 \f
 111 ;;; D-Bus events.
 112
 113 (defun dbus-check-event (event)
 114   "Checks whether EVENT is a well formed D-Bus event.
 115 EVENT is a list which starts with symbol `dbus-event':
 116
 117      (dbus-event BUS SERVICE PATH INTERFACE MEMBER HANDLER &rest ARGS)
 118
 119 BUS identifies the D-Bus the signal is coming from.  It is either
 120 the symbol `:system' or the symbol `:session'.  SERVICE and PATH
 121 are the unique name and the object path of the D-Bus object
 122 emitting the signal.  INTERFACE and MEMBER denote the signal
 123 which has been sent.  HANDLER is the function which has been
 124 registered for this signal.  ARGS are the arguments passed to
 125 HANDLER, when it is called during event handling in
 126 `dbus-handle-event'.
 127
 128 This function raises a `dbus-error' signal in case the event is
 129 not well formed."
 130   (when dbus-debug (message "DBus-Event %s" event))
 131   (unless (and (listp event)
 132                (eq (car event) 'dbus-event)
 133                ;; Bus symbol.
 134                (symbolp (nth 1 event))
 135                ;; Service.
 136                (stringp (nth 2 event))
 137                ;; Object path.
 138                (stringp (nth 3 event))
 139                ;; Interface.
 140                (stringp (nth 4 event))
 141                ;; Member.
 142                (stringp (nth 5 event))
 143                ;; Handler.
 144                (functionp (nth 6 event)))
 145     (signal 'dbus-error (list "Not a valid D-Bus event" event))))
 146
 147 ;;;###autoload
 148 (defun dbus-handle-event (event)
 149   "Handle events from the D-Bus.
 150 EVENT is a D-Bus event, see `dbus-check-event'.  HANDLER, being
 151 part of the event, is called with arguments ARGS."
 152   (interactive "e")
 153   ;; We don't want to raise an error, because this function is called
 154   ;; in the event handling loop.
 155   (condition-case nil
 156       (progn
 157         (dbus-check-event event)
 158         (apply (nth 6 event) (nthcdr 7 event)))
 159     (dbus-error)))
 160
 161 (defun dbus-event-bus-name (event)
 162   "Return the bus name the event is coming from.
 163 The result is either the symbol `:system' or the symbol `:session'.
 164 EVENT is a D-Bus event, see `dbus-check-event'.  This function
 165 raises a `dbus-error' signal in case the event is not well
 166 formed."
 167   (dbus-check-event event)
 168   (nth 1 event))
 169
 170 (defun dbus-event-service-name (event)
 171   "Return the name of the D-Bus object the event is coming from.
 172 The result is a string.  EVENT is a D-Bus event, see `dbus-check-event'.
 173 This function raises a `dbus-error' signal in case the event is
 174 not well formed."
 175   (dbus-check-event event)
 176   (nth 2 event))
 177
 178 (defun dbus-event-path-name (event)
 179   "Return the object path of the D-Bus object the event is coming from.
 180 The result is a string.  EVENT is a D-Bus event, see `dbus-check-event'.
 181 This function raises a `dbus-error' signal in case the event is
 182 not well formed."
 183   (dbus-check-event event)
 184   (nth 3 event))
 185
 186 (defun dbus-event-interface-name (event)
 187   "Return the interface name of the D-Bus object the event is coming from.
 188 The result is a string.  EVENT is a D-Bus event, see `dbus-check-event'.
 189 This function raises a `dbus-error' signal in case the event is
 190 not well formed."
 191   (dbus-check-event event)
 192   (nth 4 event))
 193
 194 (defun dbus-event-member-name (event)
 195   "Return the member name the event is coming from.
 196 It is either a signal name or a method name. The result is is a
 197 string.  EVENT is a D-Bus event, see `dbus-check-event'.  This
 198 function raises a `dbus-error' signal in case the event is not
 199 well formed."
 200   (dbus-check-event event)
 201   (nth 5 event))
 202
 203 \f
 204 ;;; D-Bus registered names.
 205
 206 (defun dbus-list-activatable-names ()
 207   "Return the D-Bus service names which can be activated as list.
 208 The result is a list of strings, which is nil when there are no
 209 activatable service names at all."
 210   (condition-case nil
 211       (dbus-call-method
 212        :system dbus-service-dbus
 213        dbus-path-dbus dbus-interface-dbus "ListActivatableNames")
 214     (dbus-error)))
 215
 216 (defun dbus-list-names (bus)
 217   "Return the service names registered at D-Bus BUS.
 218 The result is a list of strings, which is nil when there are no
 219 registered service names at all.  Well known names are strings like
 220 \"org.freedesktop.DBus\".  Names starting with \":\" are unique names
 221 for services."
 222   (condition-case nil
 223       (dbus-call-method
 224        bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "ListNames")
 225     (dbus-error)))
 226
 227 (defun dbus-list-known-names (bus)
 228   "Retrieve all services which correspond to a known name in BUS.
 229 A service has a known name if it doesn't start with \":\"."
 230   (let (result)
 231     (dolist (name (dbus-list-names bus) result)
 232       (unless (string-equal ":" (substring name 0 1))
 233         (add-to-list 'result name 'append)))))
 234
 235 (defun dbus-list-queued-owners (bus service)
 236 "Return the unique names registered at D-Bus BUS and queued for SERVICE.
 237 The result is a list of strings, or nil when there are no queued name
 238 owners service names at all."
 239   (condition-case nil
 240       (dbus-call-method
 241        bus dbus-service-dbus dbus-path-dbus
 242        dbus-interface-dbus "ListQueuedOwners" service)
 243     (dbus-error)))
 244
 245 (defun dbus-get-name-owner (bus service)
 246   "Return the name owner of SERVICE registered at D-Bus BUS.
 247 The result is either a string, or nil if there is no name owner."
 248   (condition-case nil
 249       (dbus-call-method
 250        bus dbus-service-dbus dbus-path-dbus
 251        dbus-interface-dbus "GetNameOwner" service)
 252     (dbus-error)))
 253
 254 (defun dbus-introspect (bus service path)
 255   "Return the introspection data of SERVICE in D-Bus BUS at object path PATH.
 256 The data are in XML format.
 257
 258 Example:
 259
 260 \(dbus-introspect
 261   :system \"org.freedesktop.Hal\"
 262   \"/org/freedesktop/Hal/devices/computer\")"
 263   (condition-case nil
 264       (dbus-call-method
 265        bus service path dbus-interface-introspectable "Introspect")
 266     (dbus-error)))
 267
 268 (if nil ;; Must be reworked.  Shall we offer D-Bus signatures at all?
 269 (defun dbus-get-signatures (bus interface signal)
 270   "Retrieve SIGNAL's type signatures from D-Bus.
 271 The result is a list of SIGNAL's type signatures.  Example:
 272
 273   \(\"s\" \"b\" \"ai\"\)
 274
 275 This list represents 3 parameters of SIGNAL.  The first parameter
 276 is of type string, the second parameter is of type boolean, and
 277 the third parameter is of type array of integer.
 278
 279 If INTERFACE or SIGNAL do not exist, or if they do not support
 280 the D-Bus method org.freedesktop.DBus.Introspectable.Introspect,
 281 the function returns nil."
 282   (condition-case nil
 283       (let ((introspect-xml
 284              (with-temp-buffer
 285                (insert (dbus-introspect bus interface))
 286                (xml-parse-region (point-min) (point-max))))
 287             node interfaces signals args result)
 288         ;; Get the root node.
 289         (setq node (xml-node-name introspect-xml))
 290         ;; Get all interfaces.
 291         (setq interfaces (xml-get-children node 'interface))
 292         (while interfaces
 293           (when (string-equal (xml-get-attribute (car interfaces) 'name)
 294                               interface)
 295             ;; That's the requested interface.  Check for signals.
 296             (setq signals (xml-get-children (car interfaces) 'signal))
 297             (while signals
 298               (when (string-equal (xml-get-attribute (car signals) 'name)
 299                                   signal)
 300                 ;; The signal we are looking for.
 301                 (setq args (xml-get-children (car signals) 'arg))
 302                 (while args
 303                   (unless (xml-get-attribute (car args) 'type)
 304                     ;; This shouldn't happen, let's escape.
 305                     (signal 'dbus-error ""))
 306                   ;; We append the signature.
 307                   (setq
 308                    result (append result
 309                                   (list (xml-get-attribute (car args) 'type))))
 310                   (setq args (cdr args)))
 311                 (setq signals nil))
 312               (setq signals (cdr signals)))
 313             (setq interfaces nil))
 314           (setq interfaces (cdr interfaces)))
 315         result)
 316     ;; We ignore `dbus-error'.  There might be no introspectable interface.
 317     (dbus-error nil)))
 318 ) ;; (if nil ...
 319
 320 (provide 'dbus)
 321
 322 ;; arch-tag: a47caf84-9162-4811-90cc-5d388e37b9bd
 323 ;;; dbus.el ends here