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, 2008 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 ;; D-Bus support in the Emacs core can be disabled with configuration
  36 ;; option "--without-dbus".  Check it.
  37 (assert (featurep 'dbusbind) nil "D-Bus is not supported")
  38
  39 (require 'xml)
  40
  41 (defconst dbus-service-dbus "org.freedesktop.DBus"
  42   "The bus name used to talk to the bus itself.")
  43
  44 (defconst dbus-path-dbus "/org/freedesktop/DBus"
  45   "The object path used to talk to the bus itself.")
  46
  47 (defconst dbus-interface-dbus "org.freedesktop.DBus"
  48   "The interface exported by the object with `dbus-service-dbus' and `dbus-path-dbus'.")
  49
  50 (defconst dbus-interface-introspectable "org.freedesktop.DBus.Introspectable"
  51   "The interface supported by introspectable objects.")
  52
  53 (defmacro dbus-ignore-errors (&rest body)
  54   "Execute BODY; signal D-Bus error when `dbus-debug' is non-nil.
  55 Otherwise, return result of last form in BODY, or all other errors."
  56   `(condition-case err
  57        (progn ,@body)
  58      (dbus-error (when dbus-debug (signal (car err) (cdr err))))))
  59
  60 (put 'dbus-ignore-errors 'lisp-indent-function 0)
  61 (put 'dbus-ignore-errors 'edebug-form-spec '(form symbolp body))
  62 (font-lock-add-keywords 'emacs-lisp-mode '("\\<dbus-ignore-errors\\>"))
  63
  64 \f
  65 ;;; Hash table of registered functions.
  66
  67 ;; We create it here.  So we have a simple test in dbusbind.c, whether
  68 ;; the Lisp code has been loaded.
  69 (setq dbus-registered-functions-table (make-hash-table :test 'equal))
  70
  71 (defun dbus-list-hash-table ()
  72   "Returns all registered member registrations to D-Bus.
  73 The return value is a list, with elements of kind (KEY . VALUE).
  74 See `dbus-registered-functions-table' for a description of the
  75 hash table."
  76   (let (result)
  77     (maphash
  78      '(lambda (key value) (add-to-list 'result (cons key value) 'append))
  79      dbus-registered-functions-table)
  80     result))
  81
  82 (defun dbus-unregister-object (object)
  83   "Unregister OBJECT from D-Bus.
  84 OBJECT must be the result of a preceding `dbus-register-method'
  85 or `dbus-register-signal' call.  It returns t if OBJECT has been
  86 unregistered, nil otherwise."
  87   ;; Check parameter.
  88   (unless (and (consp object) (not (null (car object))) (consp (cdr object)))
  89     (signal 'wrong-type-argument (list 'D-Bus object)))
  90
  91   ;; Find the corresponding entry in the hash table.
  92   (let* ((key (car object))
  93          (value (gethash key dbus-registered-functions-table)))
  94     ;; Loop over the registered functions.
  95     (while (consp value)
  96       ;; (car value) has the structure (UNAME SERVICE PATH HANDLER).
  97       ;; (cdr object) has the structure ((SERVICE PATH HANDLER) ...).
  98       (if (not (equal (cdr (car value)) (car (cdr object))))
  99           (setq value (cdr value))
 100         ;; Compute new hash value.  If it is empty, remove it from
 101         ;; hash table.
 102         (unless
 103             (puthash
 104              key
 105              (delete (car value) (gethash key dbus-registered-functions-table))
 106              dbus-registered-functions-table)
 107           (remhash key dbus-registered-functions-table))
 108         (setq value t)))
 109     value))
 110
 111 (defun dbus-name-owner-changed-handler (&rest args)
 112   "Reapplies all member registrations to D-Bus.
 113 This handler is applied when a \"NameOwnerChanged\" signal has
 114 arrived.  SERVICE is the object name for which the name owner has
 115 been changed.  OLD-OWNER is the previous owner of SERVICE, or the
 116 empty string if SERVICE was not owned yet.  NEW-OWNER is the new
 117 owner of SERVICE, or the empty string if SERVICE looses any name owner.
 118
 119 usage: (dbus-name-owner-changed-handler service old-owner new-owner)"
 120   (save-match-data
 121     ;; Check the arguments.  We should silently ignore it when they
 122     ;; are wrong.
 123     (if (and (= (length args) 3)
 124              (stringp (car args))
 125              (stringp (cadr args))
 126              (stringp (caddr args)))
 127         (let ((service (car args))
 128               (old-owner (cadr args))
 129               (new-owner (caddr args)))
 130           ;; Check whether SERVICE is a known name.
 131           (when (not (string-match "^:" service))
 132             (maphash
 133              '(lambda (key value)
 134                 (dolist (elt value)
 135                   ;; key has the structure (BUS INTERFACE MEMBER).
 136                   ;; elt has the structure (UNAME SERVICE PATH HANDLER).
 137                   (when (string-equal old-owner (car elt))
 138                     ;; Remove old key, and add new entry with changed name.
 139                     (dbus-unregister-object (list key (cdr elt)))
 140                     ;; Maybe we could arrange the lists a little bit better
 141                     ;; that we don't need to extract every single element?
 142                     (dbus-register-signal
 143                      ;; BUS      SERVICE     PATH
 144                      (nth 0 key) (nth 1 elt) (nth 2 elt)
 145                      ;; INTERFACE MEMBER     HANDLER
 146                      (nth 1 key) (nth 2 key) (nth 3 elt)))))
 147              (copy-hash-table dbus-registered-functions-table))))
 148       ;; The error is reported only in debug mode.
 149       (when  dbus-debug
 150         (signal
 151          'dbus-error
 152          (cons
 153           (format "Wrong arguments of %s.NameOwnerChanged" dbus-interface-dbus)
 154           args))))))
 155
 156 ;; Register the handler.
 157 (dbus-ignore-errors
 158   (dbus-register-signal
 159    :system dbus-service-dbus dbus-path-dbus dbus-interface-dbus
 160    "NameOwnerChanged" 'dbus-name-owner-changed-handler)
 161   (dbus-register-signal
 162    :session dbus-service-dbus dbus-path-dbus dbus-interface-dbus
 163    "NameOwnerChanged" 'dbus-name-owner-changed-handler))
 164
 165 \f
 166 ;;; D-Bus events.
 167
 168 (defun dbus-check-event (event)
 169   "Checks whether EVENT is a well formed D-Bus event.
 170 EVENT is a list which starts with symbol `dbus-event':
 171
 172      (dbus-event BUS SERIAL SERVICE PATH INTERFACE MEMBER HANDLER &rest ARGS)
 173
 174 BUS identifies the D-Bus the message is coming from.  It is
 175 either the symbol `:system' or the symbol `:session'.  SERIAL is
 176 the serial number of the received D-Bus message if it is a method
 177 call, or nil.  SERVICE and PATH are the unique name and the
 178 object path of the D-Bus object emitting the message.  INTERFACE
 179 and MEMBER denote the message which has been sent.  HANDLER is
 180 the function which has been registered for this message.  ARGS
 181 are the arguments passed to HANDLER, when it is called during
 182 event handling in `dbus-handle-event'.
 183
 184 This function raises a `dbus-error' signal in case the event is
 185 not well formed."
 186   (when dbus-debug (message "DBus-Event %s" event))
 187   (unless (and (listp event)
 188                (eq (car event) 'dbus-event)
 189                ;; Bus symbol.
 190                (symbolp (nth 1 event))
 191                ;; Serial.
 192                (or (natnump (nth 2 event)) (null (nth 2 event)))
 193                ;; Service.
 194                (stringp (nth 3 event))
 195                ;; Object path.
 196                (stringp (nth 4 event))
 197                ;; Interface.
 198                (stringp (nth 5 event))
 199                ;; Member.
 200                (stringp (nth 6 event))
 201                ;; Handler.
 202                (functionp (nth 7 event)))
 203     (signal 'dbus-error (list "Not a valid D-Bus event" event))))
 204
 205 ;;;###autoload
 206 (defun dbus-handle-event (event)
 207   "Handle events from the D-Bus.
 208 EVENT is a D-Bus event, see `dbus-check-event'.  HANDLER, being
 209 part of the event, is called with arguments ARGS."
 210   (interactive "e")
 211   ;; We don't want to raise an error, because this function is called
 212   ;; in the event handling loop.
 213   (dbus-ignore-errors
 214     (let (result)
 215       (dbus-check-event event)
 216       (setq result (apply (nth 7 event) (nthcdr 8 event)))
 217       (unless (consp result) (setq result (cons result nil)))
 218       ;; Return a message when serial is not nil.
 219       (when (not (null (nth 2 event)))
 220         (apply 'dbus-method-return-internal
 221                (nth 1 event) (nth 2 event) (nth 3 event) result)))))
 222
 223 (defun dbus-event-bus-name (event)
 224   "Return the bus name the event is coming from.
 225 The result is either the symbol `:system' or the symbol `:session'.
 226 EVENT is a D-Bus event, see `dbus-check-event'.  This function
 227 raises a `dbus-error' signal in case the event is not well
 228 formed."
 229   (dbus-check-event event)
 230   (nth 1 event))
 231
 232 (defun dbus-event-serial-number (event)
 233   "Return the serial number of the corresponding D-Bus message.
 234 The result is a number in case the D-Bus message is a method
 235 call, or nil for all other mesage types.  The serial number is
 236 needed for generating a reply message.  EVENT is a D-Bus event,
 237 see `dbus-check-event'.  This function raises a `dbus-error'
 238 signal in case the event is not well formed."
 239   (dbus-check-event event)
 240   (nth 2 event))
 241
 242 (defun dbus-event-service-name (event)
 243   "Return the name of the D-Bus object the event is coming from.
 244 The result is a string.  EVENT is a D-Bus event, see `dbus-check-event'.
 245 This function raises a `dbus-error' signal in case the event is
 246 not well formed."
 247   (dbus-check-event event)
 248   (nth 3 event))
 249
 250 (defun dbus-event-path-name (event)
 251   "Return the object path of the D-Bus object the event is coming from.
 252 The result is a string.  EVENT is a D-Bus event, see `dbus-check-event'.
 253 This function raises a `dbus-error' signal in case the event is
 254 not well formed."
 255   (dbus-check-event event)
 256   (nth 4 event))
 257
 258 (defun dbus-event-interface-name (event)
 259   "Return the interface name of the D-Bus object the event is coming from.
 260 The result is a string.  EVENT is a D-Bus event, see `dbus-check-event'.
 261 This function raises a `dbus-error' signal in case the event is
 262 not well formed."
 263   (dbus-check-event event)
 264   (nth 5 event))
 265
 266 (defun dbus-event-member-name (event)
 267   "Return the member name the event is coming from.
 268 It is either a signal name or a method name. The result is is a
 269 string.  EVENT is a D-Bus event, see `dbus-check-event'.  This
 270 function raises a `dbus-error' signal in case the event is not
 271 well formed."
 272   (dbus-check-event event)
 273   (nth 6 event))
 274
 275 \f
 276 ;;; D-Bus registered names.
 277
 278 (defun dbus-list-activatable-names ()
 279   "Return the D-Bus service names which can be activated as list.
 280 The result is a list of strings, which is nil when there are no
 281 activatable service names at all."
 282   (dbus-ignore-errors
 283     (dbus-call-method
 284      :system dbus-service-dbus
 285      dbus-path-dbus dbus-interface-dbus "ListActivatableNames")))
 286
 287 (defun dbus-list-names (bus)
 288   "Return the service names registered at D-Bus BUS.
 289 The result is a list of strings, which is nil when there are no
 290 registered service names at all.  Well known names are strings like
 291 \"org.freedesktop.DBus\".  Names starting with \":\" are unique names
 292 for services."
 293   (dbus-ignore-errors
 294     (dbus-call-method
 295      bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "ListNames")))
 296
 297 (defun dbus-list-known-names (bus)
 298   "Retrieve all services which correspond to a known name in BUS.
 299 A service has a known name if it doesn't start with \":\"."
 300   (let (result)
 301     (dolist (name (dbus-list-names bus) result)
 302       (unless (string-equal ":" (substring name 0 1))
 303         (add-to-list 'result name 'append)))))
 304
 305 (defun dbus-list-queued-owners (bus service)
 306 "Return the unique names registered at D-Bus BUS and queued for SERVICE.
 307 The result is a list of strings, or nil when there are no queued name
 308 owners service names at all."
 309   (dbus-ignore-errors
 310     (dbus-call-method
 311      bus dbus-service-dbus dbus-path-dbus
 312      dbus-interface-dbus "ListQueuedOwners" service)))
 313
 314 (defun dbus-get-name-owner (bus service)
 315   "Return the name owner of SERVICE registered at D-Bus BUS.
 316 The result is either a string, or nil if there is no name owner."
 317   (dbus-ignore-errors
 318     (dbus-call-method
 319      bus dbus-service-dbus dbus-path-dbus
 320      dbus-interface-dbus "GetNameOwner" service)))
 321
 322 (defun dbus-introspect (bus service path)
 323   "Return the introspection data of SERVICE in D-Bus BUS at object path PATH.
 324 The data are in XML format.
 325
 326 Example:
 327
 328 \(dbus-introspect
 329   :system \"org.freedesktop.Hal\"
 330   \"/org/freedesktop/Hal/devices/computer\")"
 331   (dbus-ignore-errors
 332     (dbus-call-method
 333      bus service path dbus-interface-introspectable "Introspect")))
 334
 335 (if nil ;; Must be reworked.  Shall we offer D-Bus signatures at all?
 336 (defun dbus-get-signatures (bus interface signal)
 337   "Retrieve SIGNAL's type signatures from D-Bus.
 338 The result is a list of SIGNAL's type signatures.  Example:
 339
 340   \(\"s\" \"b\" \"ai\"\)
 341
 342 This list represents 3 parameters of SIGNAL.  The first parameter
 343 is of type string, the second parameter is of type boolean, and
 344 the third parameter is of type array of integer.
 345
 346 If INTERFACE or SIGNAL do not exist, or if they do not support
 347 the D-Bus method org.freedesktop.DBus.Introspectable.Introspect,
 348 the function returns nil."
 349   (dbus-ignore-errors
 350     (let ((introspect-xml
 351            (with-temp-buffer
 352              (insert (dbus-introspect bus interface))
 353              (xml-parse-region (point-min) (point-max))))
 354           node interfaces signals args result)
 355       ;; Get the root node.
 356       (setq node (xml-node-name introspect-xml))
 357       ;; Get all interfaces.
 358       (setq interfaces (xml-get-children node 'interface))
 359       (while interfaces
 360         (when (string-equal (xml-get-attribute (car interfaces) 'name)
 361                             interface)
 362           ;; That's the requested interface.  Check for signals.
 363           (setq signals (xml-get-children (car interfaces) 'signal))
 364           (while signals
 365             (when (string-equal (xml-get-attribute (car signals) 'name) signal)
 366               ;; The signal we are looking for.
 367               (setq args (xml-get-children (car signals) 'arg))
 368               (while args
 369                 (unless (xml-get-attribute (car args) 'type)
 370                   ;; This shouldn't happen, let's escape.
 371                   (signal 'dbus-error nil))
 372                 ;; We append the signature.
 373                 (setq
 374                  result (append result
 375                                 (list (xml-get-attribute (car args) 'type))))
 376                 (setq args (cdr args)))
 377               (setq signals nil))
 378             (setq signals (cdr signals)))
 379           (setq interfaces nil))
 380         (setq interfaces (cdr interfaces)))
 381       result)))
 382 ) ;; (if nil ...
 383
 384 (provide 'dbus)
 385
 386 ;; arch-tag: a47caf84-9162-4811-90cc-5d388e37b9bd
 387 ;;; dbus.el ends here