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