code.delx.au - gnu-emacs/blob - 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 (defun dbus-hash-table= (x y)
  53   "Compares keys X and Y in the hash table of registered functions for D-Bus.
  54 See `dbus-registered-functions-table' for a description of the hash table."
  55   (and
  56    ;; Bus symbol, either :system or :session.
  57    (equal (car x) (car y))
  58    ;; Service.
  59    (or
  60     (null (nth 1 x)) (null (nth 1 y)) ; wildcard
  61     (string-equal (nth 1 x) (nth 1 y)))
  62    ;; Path.
  63    (or
  64     (null (nth 2 x)) (null (nth 2 y)) ; wildcard
  65     (string-equal (nth 2 x) (nth 2 y)))
  66    ;; Member.
  67    (or
  68     (null (nth 3 x)) (null (nth 3 y)) ; wildcard
  69     (string-equal (nth 3 x) (nth 3 y)))
  70    ;; Interface.
  71    (or
  72     (null (nth 4 x)) (null (nth 4 y)) ; wildcard
  73     (string-equal (nth 4 x) (nth 4 y)))))
  74
  75 (define-hash-table-test 'dbus-hash-table-test 'dbus-hash-table= 'sxhash)
  76
  77 ;; When we assume that service, path, interface and and member are
  78 ;; always strings in the key, we could use `equal' as test function.
  79 ;; But we want to have also `nil' there, being a wildcard.
  80 (setq dbus-registered-functions-table
  81       (make-hash-table :test 'dbus-hash-table-test))
  82
  83 (defun dbus-list-hash-table ()
  84   "Returns all registered signal registrations to D-Bus.
  85 The return value is a list, with elements of kind (KEY . VALUE).
  86 See `dbus-registered-functions-table' for a description of the
  87 hash table."
  88   (let (result)
  89     (maphash
  90      '(lambda (key value) (add-to-list 'result (cons key value) 'append))
  91      dbus-registered-functions-table)
  92     result))
  93
  94 (defun dbus-name-owner-changed-handler (service old-owner new-owner)
  95   "Reapplies all signal registrations to D-Bus.
  96 This handler is applied when a \"NameOwnerChanged\" signal has
  97 arrived.  SERVICE is the object name for which the name owner has
  98 been changed.  OLD-OWNER is the previous owner of SERVICE, or the
  99 empty string if SERVICE was not owned yet.  NEW-OWNER is the new
 100 owner of SERVICE, or the empty string if SERVICE looses any name owner."
 101   (save-match-data
 102     ;; Check whether SERVICE is a known name, and OLD-OWNER and
 103     ;; NEW-OWNER are defined.
 104     (when (and (stringp service) (not (string-match "^:" service))
 105                (not (zerop (length old-owner)))
 106                (not (zerop (length new-owner))))
 107       (let ((bus (dbus-event-bus-name last-input-event)))
 108         (maphash
 109          '(lambda (key value)
 110             ;; Check for matching bus and service name.
 111             (when (and (equal bus (car key))
 112                        (string-equal old-owner (nth 1 key)))
 113               ;; Remove old key, and add new entry with changed name.
 114               (when dbus-debug (message "Remove rule for %s" key))
 115               (dbus-unregister-signal key)
 116               (setcar (nthcdr 1 key) new-owner)
 117               (when dbus-debug (message "Add rule for %s" key))
 118               (apply 'dbus-register-signal (append key (list value)))))
 119          (copy-hash-table dbus-registered-functions-table))))))
 120
 121 ;; Register the handler.
 122 (condition-case nil
 123     (progn
 124       (dbus-register-signal
 125        :system dbus-service-dbus dbus-path-dbus dbus-interface-dbus
 126        "NameOwnerChanged" 'dbus-name-owner-changed-handler)
 127       (dbus-register-signal
 128        :session dbus-service-dbus dbus-path-dbus dbus-interface-dbus
 129        "NameOwnerChanged" 'dbus-name-owner-changed-handler))
 130   (dbus-error))
 131
 132 \f
 133 ;;; D-Bus events.
 134
 135 (defun dbus-check-event (event)
 136   "Checks whether EVENT is a well formed D-Bus event.
 137 EVENT is a list which starts with symbol `dbus-event':
 138
 139      (dbus-event BUS SERVICE PATH INTERFACE MEMBER HANDLER &rest ARGS)
 140
 141 BUS identifies the D-Bus the signal is coming from.  It is either
 142 the symbol `:system' or the symbol `:session'.  SERVICE and PATH
 143 are the unique name and the object path of the D-Bus object
 144 emitting the signal.  INTERFACE and MEMBER denote the signal
 145 which has been sent.  HANDLER is the function which has been
 146 registered for this signal.  ARGS are the arguments passed to
 147 HANDLER, when it is called during event handling in
 148 `dbus-handle-event'.
 149
 150 This function raises a `dbus-error' signal in case the event is
 151 not well formed."
 152   (when dbus-debug (message "DBus-Event %s" event))
 153   (unless (and (listp event)
 154                (eq (car event) 'dbus-event)
 155                ;; Bus symbol.
 156                (symbolp (nth 1 event))
 157                ;; Service.
 158                (stringp (nth 2 event))
 159                ;; Object path.
 160                (stringp (nth 3 event))
 161                ;; Interface.
 162                (stringp (nth 4 event))
 163                ;; Member.
 164                (stringp (nth 5 event))
 165                ;; Handler.
 166                (functionp (nth 6 event)))
 167     (signal 'dbus-error (list "Not a valid D-Bus event" event))))
 168
 169 ;;;###autoload
 170 (defun dbus-handle-event (event)
 171   "Handle events from the D-Bus.
 172 EVENT is a D-Bus event, see `dbus-check-event'.  HANDLER, being
 173 part of the event, is called with arguments ARGS."
 174   (interactive "e")
 175   ;; We don't want to raise an error, because this function is called
 176   ;; in the event handling loop.
 177   (condition-case nil
 178       (progn
 179         (dbus-check-event event)
 180         (apply (nth 6 event) (nthcdr 7 event)))
 181     (dbus-error)))
 182
 183 (defun dbus-event-bus-name (event)
 184   "Return the bus name the event is coming from.
 185 The result is either the symbol `:system' or the symbol `:session'.
 186 EVENT is a D-Bus event, see `dbus-check-event'.  This function
 187 raises a `dbus-error' signal in case the event is not well
 188 formed."
 189   (dbus-check-event event)
 190   (nth 1 event))
 191
 192 (defun dbus-event-service-name (event)
 193   "Return the name of the D-Bus object the event is coming from.
 194 The result is a string.  EVENT is a D-Bus event, see `dbus-check-event'.
 195 This function raises a `dbus-error' signal in case the event is
 196 not well formed."
 197   (dbus-check-event event)
 198   (nth 2 event))
 199
 200 (defun dbus-event-path-name (event)
 201   "Return the object path of the D-Bus object the event is coming from.
 202 The result is a string.  EVENT is a D-Bus event, see `dbus-check-event'.
 203 This function raises a `dbus-error' signal in case the event is
 204 not well formed."
 205   (dbus-check-event event)
 206   (nth 3 event))
 207
 208 (defun dbus-event-interface-name (event)
 209   "Return the interface name of the D-Bus object the event is coming from.
 210 The result is a string.  EVENT is a D-Bus event, see `dbus-check-event'.
 211 This function raises a `dbus-error' signal in case the event is
 212 not well formed."
 213   (dbus-check-event event)
 214   (nth 4 event))
 215
 216 (defun dbus-event-member-name (event)
 217   "Return the member name the event is coming from.
 218 It is either a signal name or a method name. The result is is a
 219 string.  EVENT is a D-Bus event, see `dbus-check-event'.  This
 220 function raises a `dbus-error' signal in case the event is not
 221 well formed."
 222   (dbus-check-event event)
 223   (nth 5 event))
 224
 225 \f
 226 ;;; D-Bus registered names.
 227
 228 (defun dbus-list-activatable-names ()
 229   "Return the D-Bus service names which can be activated as list.
 230 The result is a list of strings, which is nil when there are no
 231 activatable service names at all."
 232   (condition-case nil
 233       (dbus-call-method
 234        :system dbus-service-dbus
 235        dbus-path-dbus dbus-interface-dbus "ListActivatableNames")
 236     (dbus-error)))
 237
 238 (defun dbus-list-names (bus)
 239   "Return the service names registered at D-Bus BUS.
 240 The result is a list of strings, which is nil when there are no
 241 registered service names at all.  Well known names are strings like
 242 \"org.freedesktop.DBus\".  Names starting with \":\" are unique names
 243 for services."
 244   (condition-case nil
 245       (dbus-call-method
 246        bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "ListNames")
 247     (dbus-error)))
 248
 249 (defun dbus-list-known-names (bus)
 250   "Retrieve all services which correspond to a known name in BUS.
 251 A service has a known name if it doesn't start with \":\"."
 252   (let (result)
 253     (dolist (name (dbus-list-names bus) result)
 254       (unless (string-equal ":" (substring name 0 1))
 255         (add-to-list 'result name 'append)))))
 256
 257 (defun dbus-list-queued-owners (bus service)
 258 "Return the unique names registered at D-Bus BUS and queued for SERVICE.
 259 The result is a list of strings, or nil when there are no queued name
 260 owners service names at all."
 261   (condition-case nil
 262       (dbus-call-method
 263        bus dbus-service-dbus dbus-path-dbus
 264        dbus-interface-dbus "ListQueuedOwners" service)
 265     (dbus-error)))
 266
 267 (defun dbus-get-name-owner (bus service)
 268   "Return the name owner of SERVICE registered at D-Bus BUS.
 269 The result is either a string, or nil if there is no name owner."
 270   (condition-case nil
 271       (dbus-call-method
 272        bus dbus-service-dbus dbus-path-dbus
 273        dbus-interface-dbus "GetNameOwner" service)
 274     (dbus-error)))
 275
 276 (defun dbus-introspect (bus service path)
 277   "Return the introspection data of SERVICE in D-Bus BUS at object path PATH.
 278 The data are in XML format.
 279
 280 Example:
 281
 282 \(dbus-introspect
 283   :system \"org.freedesktop.Hal\"
 284   \"/org/freedesktop/Hal/devices/computer\")"
 285   (condition-case nil
 286       (dbus-call-method
 287        bus service path dbus-interface-introspectable "Introspect")
 288     (dbus-error)))
 289
 290 (if nil ;; Must be reworked.  Shall we offer D-Bus signatures at all?
 291 (defun dbus-get-signatures (bus interface signal)
 292   "Retrieve SIGNAL's type signatures from D-Bus.
 293 The result is a list of SIGNAL's type signatures.  Example:
 294
 295   \(\"s\" \"b\" \"ai\"\)
 296
 297 This list represents 3 parameters of SIGNAL.  The first parameter
 298 is of type string, the second parameter is of type boolean, and
 299 the third parameter is of type array of integer.
 300
 301 If INTERFACE or SIGNAL do not exist, or if they do not support
 302 the D-Bus method org.freedesktop.DBus.Introspectable.Introspect,
 303 the function returns nil."
 304   (condition-case nil
 305       (let ((introspect-xml
 306              (with-temp-buffer
 307                (insert (dbus-introspect bus interface))
 308                (xml-parse-region (point-min) (point-max))))
 309             node interfaces signals args result)
 310         ;; Get the root node.
 311         (setq node (xml-node-name introspect-xml))
 312         ;; Get all interfaces.
 313         (setq interfaces (xml-get-children node 'interface))
 314         (while interfaces
 315           (when (string-equal (xml-get-attribute (car interfaces) 'name)
 316                               interface)
 317             ;; That's the requested interface.  Check for signals.
 318             (setq signals (xml-get-children (car interfaces) 'signal))
 319             (while signals
 320               (when (string-equal (xml-get-attribute (car signals) 'name)
 321                                   signal)
 322                 ;; The signal we are looking for.
 323                 (setq args (xml-get-children (car signals) 'arg))
 324                 (while args
 325                   (unless (xml-get-attribute (car args) 'type)
 326                     ;; This shouldn't happen, let's escape.
 327                     (signal 'dbus-error ""))
 328                   ;; We append the signature.
 329                   (setq
 330                    result (append result
 331                                   (list (xml-get-attribute (car args) 'type))))
 332                   (setq args (cdr args)))
 333                 (setq signals nil))
 334               (setq signals (cdr signals)))
 335             (setq interfaces nil))
 336           (setq interfaces (cdr interfaces)))
 337         result)
 338     ;; We ignore `dbus-error'.  There might be no introspectable interface.
 339     (dbus-error nil)))
 340 ) ;; (if nil ...
 341
 342 (provide 'dbus)
 343
 344 ;; arch-tag: a47caf84-9162-4811-90cc-5d388e37b9bd
 345 ;;; dbus.el ends here