code.delx.au - gnu-emacs/blob - lisp/net/dbus.el

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