lisp/net/dbus.el

   1 ;;; dbus.el --- Elisp bindings for D-Bus.
   2
   3 ;; Copyright (C) 2007, 2008, 2009, 2010 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-call-method-asynchronously "dbusbind.c")
  37 (declare-function dbus-init-bus "dbusbind.c")
  38 (declare-function dbus-method-return-internal "dbusbind.c")
  39 (declare-function dbus-method-error-internal "dbusbind.c")
  40 (declare-function dbus-register-signal "dbusbind.c")
  41 (declare-function dbus-register-method "dbusbind.c")
  42 (declare-function dbus-send-signal "dbusbind.c")
  43 (defvar dbus-debug)
  44 (defvar dbus-registered-objects-table)
  45
  46 ;; Pacify byte compiler.
  47 (eval-when-compile
  48   (require 'cl))
  49
  50 (require 'xml)
  51
  52 (defconst dbus-service-dbus "org.freedesktop.DBus"
  53   "The bus name used to talk to the bus itself.")
  54
  55 (defconst dbus-path-dbus "/org/freedesktop/DBus"
  56   "The object path used to talk to the bus itself.")
  57
  58 (defconst dbus-interface-dbus "org.freedesktop.DBus"
  59   "The interface exported by the object with `dbus-service-dbus' and `dbus-path-dbus'.")
  60
  61 (defconst dbus-interface-peer (concat dbus-interface-dbus ".Peer")
  62   "The interface for peer objects.")
  63
  64 (defconst dbus-interface-introspectable
  65   (concat dbus-interface-dbus ".Introspectable")
  66   "The interface supported by introspectable objects.")
  67
  68 (defconst dbus-interface-properties (concat dbus-interface-dbus ".Properties")
  69   "The interface for property objects.")
  70
  71 (defconst dbus-service-emacs "org.gnu.Emacs"
  72   "The well known service name of Emacs.")
  73
  74 (defconst dbus-path-emacs "/org/gnu/Emacs"
  75   "The object path head used by Emacs.")
  76
  77 (defconst dbus-message-type-invalid 0
  78   "This value is never a valid message type.")
  79
  80 (defconst dbus-message-type-method-call 1
  81   "Message type of a method call message.")
  82
  83 (defconst dbus-message-type-method-return 2
  84   "Message type of a method return message.")
  85
  86 (defconst dbus-message-type-error 3
  87   "Message type of an error reply message.")
  88
  89 (defconst dbus-message-type-signal 4
  90   "Message type of a signal message.")
  91
  92 (defmacro dbus-ignore-errors (&rest body)
  93   "Execute BODY; signal D-Bus error when `dbus-debug' is non-nil.
  94 Otherwise, return result of last form in BODY, or all other errors."
  95   (declare (indent 0) (debug t))
  96   `(condition-case err
  97        (progn ,@body)
  98      (dbus-error (when dbus-debug (signal (car err) (cdr err))))))
  99 (font-lock-add-keywords 'emacs-lisp-mode '("\\<dbus-ignore-errors\\>"))
 100
 101 (defvar dbus-event-error-hooks nil
 102   "Functions to be called when a D-Bus error happens in the event handler.
 103 Every function must accept two arguments, the event and the error variable
 104 catched in `condition-case' by `dbus-error'.")
 105
 106 \f
 107 ;;; Hash table of registered functions.
 108
 109 (defvar dbus-return-values-table (make-hash-table :test 'equal)
 110   "Hash table for temporary storing arguments of reply messages.
 111 A key in this hash table is a list (BUS SERIAL).  BUS is either a
 112 Lisp symbol, `:system' or `:session', or a string denoting the
 113 bus address.  SERIAL is the serial number of the reply message.
 114 See `dbus-call-method-non-blocking-handler' and
 115 `dbus-call-method-non-blocking'.")
 116
 117 (defun dbus-list-hash-table ()
 118   "Returns all registered member registrations to D-Bus.
 119 The return value is a list, with elements of kind (KEY . VALUE).
 120 See `dbus-registered-objects-table' for a description of the
 121 hash table."
 122   (let (result)
 123     (maphash
 124      '(lambda (key value) (add-to-list 'result (cons key value) 'append))
 125      dbus-registered-objects-table)
 126     result))
 127
 128 (defun dbus-unregister-object (object)
 129   "Unregister OBJECT from D-Bus.
 130 OBJECT must be the result of a preceding `dbus-register-method',
 131 `dbus-register-property' or `dbus-register-signal' call.  It
 132 returns `t' if OBJECT has been unregistered, `nil' otherwise.
 133
 134 When OBJECT identifies the last method or property, which is
 135 registered for the respective service, Emacs releases its
 136 association to the service from D-Bus."
 137   ;; Check parameter.
 138   (unless (and (consp object) (not (null (car object))) (consp (cdr object)))
 139     (signal 'wrong-type-argument (list 'D-Bus object)))
 140
 141   ;; Find the corresponding entry in the hash table.
 142   (let* ((key (car object))
 143          (value (cdr object))
 144          (entry (gethash key dbus-registered-objects-table))
 145          ret)
 146     ;; entry has the structure ((UNAME SERVICE PATH MEMBER) ...).
 147     ;; value has the structure ((SERVICE PATH [HANDLER]) ...).
 148     ;; MEMBER is either a string (the handler), or a cons cell (a
 149     ;; property value).  UNAME and property values are not taken into
 150     ;; account for comparision.
 151
 152     ;; Loop over the registered functions.
 153     (dolist (elt entry)
 154       (when (equal
 155              (car value)
 156              (butlast (cdr elt) (- (length (cdr elt)) (length (car value)))))
 157         ;; Compute new hash value.  If it is empty, remove it from the
 158         ;; hash table.
 159         (unless (puthash key (delete elt entry) dbus-registered-objects-table)
 160           (remhash key dbus-registered-objects-table))
 161         (setq ret t)))
 162     ;; Check, whether there is still a registered function or property
 163     ;; for the given service.  If not, unregister the service from the
 164     ;; bus.
 165     (dolist (elt entry)
 166       (let ((service (cadr elt))
 167             (bus (car key))
 168             found)
 169         (maphash
 170          (lambda (k v)
 171            (dolist (e v)
 172              (ignore-errors
 173                (when (and (equal bus (car k)) (string-equal service (cadr e)))
 174                  (setq found t)))))
 175          dbus-registered-objects-table)
 176         (unless found
 177           (dbus-call-method
 178            bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
 179            "ReleaseName" service))))
 180     ;; Return.
 181     ret))
 182
 183 (defun dbus-unregister-service (bus service)
 184   "Unregister all objects related to SERVICE from D-Bus BUS.
 185 BUS is either a Lisp symbol, `:system' or `:session', or a string
 186 denoting the bus address.  SERVICE must be a known service name."
 187   (maphash
 188    (lambda (key value)
 189      (dolist (elt value)
 190        (ignore-errors
 191          (when (and (equal bus (car key)) (string-equal service (cadr elt)))
 192            (unless
 193                (puthash key (delete elt value) dbus-registered-objects-table)
 194              (remhash key dbus-registered-objects-table))))))
 195    dbus-registered-objects-table)
 196   (dbus-call-method
 197    bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
 198    "ReleaseName" service))
 199
 200 (defun dbus-call-method-non-blocking-handler (&rest args)
 201   "Handler for reply messages of asynchronous D-Bus message calls.
 202 It calls the function stored in `dbus-registered-objects-table'.
 203 The result will be made available in `dbus-return-values-table'."
 204   (puthash (list (dbus-event-bus-name last-input-event)
 205                  (dbus-event-serial-number last-input-event))
 206            (if (= (length args) 1) (car args) args)
 207            dbus-return-values-table))
 208
 209 (defun dbus-call-method-non-blocking
 210   (bus service path interface method &rest args)
 211   "Call METHOD on the D-Bus BUS, but don't block the event queue.
 212 This is necessary for communicating to registered D-Bus methods,
 213 which are running in the same Emacs process.
 214
 215 The arguments are the same as in `dbus-call-method'.
 216
 217 usage: (dbus-call-method-non-blocking
 218          BUS SERVICE PATH INTERFACE METHOD
 219          &optional :timeout TIMEOUT &rest ARGS)"
 220
 221   (let ((key
 222          (apply
 223           'dbus-call-method-asynchronously
 224           bus service path interface method
 225           'dbus-call-method-non-blocking-handler args)))
 226     ;; Wait until `dbus-call-method-non-blocking-handler' has put the
 227     ;; result into `dbus-return-values-table'.
 228     (while (eq (gethash key dbus-return-values-table :ignore) :ignore)
 229       (read-event nil nil 0.1))
 230
 231     ;; Cleanup `dbus-return-values-table'.  Return the result.
 232     (prog1
 233         (gethash key dbus-return-values-table nil)
 234       (remhash key dbus-return-values-table))))
 235
 236 (defun dbus-name-owner-changed-handler (&rest args)
 237   "Reapplies all member registrations to D-Bus.
 238 This handler is applied when a \"NameOwnerChanged\" signal has
 239 arrived.  SERVICE is the object name for which the name owner has
 240 been changed.  OLD-OWNER is the previous owner of SERVICE, or the
 241 empty string if SERVICE was not owned yet.  NEW-OWNER is the new
 242 owner of SERVICE, or the empty string if SERVICE looses any name owner.
 243
 244 usage: (dbus-name-owner-changed-handler service old-owner new-owner)"
 245   (save-match-data
 246     ;; Check the arguments.  We should silently ignore it when they
 247     ;; are wrong.
 248     (if (and (= (length args) 3)
 249              (stringp (car args))
 250              (stringp (cadr args))
 251              (stringp (caddr args)))
 252         (let ((service (car args))
 253               (old-owner (cadr args))
 254               (new-owner (caddr args)))
 255           ;; Check whether SERVICE is a known name.
 256           (when (not (string-match "^:" service))
 257             (maphash
 258              '(lambda (key value)
 259                 (dolist (elt value)
 260                   ;; key has the structure (BUS INTERFACE MEMBER).
 261                   ;; elt has the structure (UNAME SERVICE PATH HANDLER).
 262                   (when (string-equal old-owner (car elt))
 263                     ;; Remove old key, and add new entry with changed name.
 264                     (dbus-unregister-object (list key (cdr elt)))
 265                     ;; Maybe we could arrange the lists a little bit better
 266                     ;; that we don't need to extract every single element?
 267                     (dbus-register-signal
 268                      ;; BUS      SERVICE     PATH
 269                      (nth 0 key) (nth 1 elt) (nth 2 elt)
 270                      ;; INTERFACE MEMBER     HANDLER
 271                      (nth 1 key) (nth 2 key) (nth 3 elt)))))
 272              (copy-hash-table dbus-registered-objects-table))))
 273       ;; The error is reported only in debug mode.
 274       (when  dbus-debug
 275         (signal
 276          'dbus-error
 277          (cons
 278           (format "Wrong arguments of %s.NameOwnerChanged" dbus-interface-dbus)
 279           args))))))
 280
 281 ;; Register the handler.
 282 (when nil ;ignore-errors
 283   (dbus-register-signal
 284    :system dbus-service-dbus dbus-path-dbus dbus-interface-dbus
 285    "NameOwnerChanged" 'dbus-name-owner-changed-handler)
 286   (dbus-register-signal
 287    :session dbus-service-dbus dbus-path-dbus dbus-interface-dbus
 288    "NameOwnerChanged" 'dbus-name-owner-changed-handler))
 289
 290 \f
 291 ;;; D-Bus type conversion.
 292
 293 (defun dbus-string-to-byte-array (string)
 294   "Transforms STRING to list (:array :byte c1 :byte c2 ...).
 295 STRING shall be UTF8 coded."
 296   (if (zerop (length string))
 297       '(:array :signature "y")
 298     (let (result)
 299       (dolist (elt (string-to-list string) (append '(:array) result))
 300         (setq result (append result (list :byte elt)))))))
 301
 302 (defun dbus-byte-array-to-string (byte-array)
 303   "Transforms BYTE-ARRAY into UTF8 coded string.
 304 BYTE-ARRAY must be a list of structure (c1 c2 ...)."
 305   (apply 'string byte-array))
 306
 307 (defun dbus-escape-as-identifier (string)
 308   "Escape an arbitrary STRING so it follows the rules for a C identifier.
 309 The escaped string can be used as object path component, interface element
 310 component, bus name component or member name in D-Bus.
 311
 312 The escaping consists of replacing all non-alphanumerics, and the
 313 first character if it's a digit, with an underscore and two
 314 lower-case hex digits:
 315
 316    \"0123abc_xyz\\x01\\xff\" -> \"_30123abc_5fxyz_01_ff\"
 317
 318 i.e. similar to URI encoding, but with \"_\" taking the role of \"%\",
 319 and a smaller allowed set. As a special case, \"\" is escaped to
 320 \"_\".
 321
 322 Returns the escaped string.  Algorithm taken from
 323 telepathy-glib's `tp-escape-as-identifier'."
 324   (if (zerop (length string))
 325       "_"
 326     (replace-regexp-in-string
 327      "^[0-9]\\|[^A-Za-z0-9]"
 328      (lambda (x) (format "_%2x" (aref x 0)))
 329      string)))
 330
 331 (defun dbus-unescape-from-identifier (string)
 332   "Retrieve the original string from the encoded STRING.
 333 STRING must have been coded with `dbus-escape-as-identifier'"
 334   (if (string-equal string "_")
 335       ""
 336     (replace-regexp-in-string
 337      "_.."
 338      (lambda (x) (format "%c" (string-to-number (substring x 1) 16)))
 339      string)))
 340
 341 \f
 342 ;;; D-Bus events.
 343
 344 (defun dbus-check-event (event)
 345   "Checks whether EVENT is a well formed D-Bus event.
 346 EVENT is a list which starts with symbol `dbus-event':
 347
 348   (dbus-event BUS TYPE SERIAL SERVICE PATH INTERFACE MEMBER HANDLER &rest ARGS)
 349
 350 BUS identifies the D-Bus the message is coming from.  It is
 351 either a Lisp symbol, `:system' or `:session', or a string
 352 denoting the bus address.  TYPE is the D-Bus message type which
 353 has caused the event, SERIAL is the serial number of the received
 354 D-Bus message.  SERVICE and PATH are the unique name and the
 355 object path of the D-Bus object emitting the message.  INTERFACE
 356 and MEMBER denote the message which has been sent.  HANDLER is
 357 the function which has been registered for this message.  ARGS
 358 are the arguments passed to HANDLER, when it is called during
 359 event handling in `dbus-handle-event'.
 360
 361 This function raises a `dbus-error' signal in case the event is
 362 not well formed."
 363   (when dbus-debug (message "DBus-Event %s" event))
 364   (unless (and (listp event)
 365                (eq (car event) 'dbus-event)
 366                ;; Bus symbol.
 367                (or (symbolp (nth 1 event))
 368                    (stringp (nth 1 event)))
 369                ;; Type.
 370                (and (natnump (nth 2 event))
 371                     (< dbus-message-type-invalid (nth 2 event)))
 372                ;; Serial.
 373                (natnump (nth 3 event))
 374                ;; Service.
 375                (or (= dbus-message-type-method-return (nth 2 event))
 376                    (= dbus-message-type-error (nth 2 event))
 377                    (stringp (nth 4 event)))
 378                ;; Object path.
 379                (or (= dbus-message-type-method-return (nth 2 event))
 380                    (= dbus-message-type-error (nth 2 event))
 381                    (stringp (nth 5 event)))
 382                ;; Interface.
 383                (or (= dbus-message-type-method-return (nth 2 event))
 384                    (= dbus-message-type-error (nth 2 event))
 385                    (stringp (nth 6 event)))
 386                ;; Member.
 387                (or (= dbus-message-type-method-return (nth 2 event))
 388                    (= dbus-message-type-error (nth 2 event))
 389                    (stringp (nth 7 event)))
 390                ;; Handler.
 391                (functionp (nth 8 event)))
 392     (signal 'dbus-error (list "Not a valid D-Bus event" event))))
 393
 394 ;;;###autoload
 395 (defun dbus-handle-event (event)
 396   "Handle events from the D-Bus.
 397 EVENT is a D-Bus event, see `dbus-check-event'.  HANDLER, being
 398 part of the event, is called with arguments ARGS.
 399 If the HANDLER returns a `dbus-error', it is propagated as return message."
 400   (interactive "e")
 401   (condition-case err
 402       (let (result)
 403         ;; We ignore not well-formed events.
 404         (dbus-check-event event)
 405         ;; Error messages must be propagated.
 406         (when (= dbus-message-type-error (nth 2 event))
 407           (signal 'dbus-error (nthcdr 9 event)))
 408         ;; Apply the handler.
 409         (setq result (apply (nth 8 event) (nthcdr 9 event)))
 410         ;; Return a message when it is a message call.
 411         (when (= dbus-message-type-method-call (nth 2 event))
 412           (dbus-ignore-errors
 413             (if (eq result :ignore)
 414                 (dbus-method-return-internal
 415                  (nth 1 event) (nth 3 event) (nth 4 event))
 416               (apply 'dbus-method-return-internal
 417                      (nth 1 event) (nth 3 event) (nth 4 event)
 418                      (if (consp result) result (list result)))))))
 419     ;; Error handling.
 420     (dbus-error
 421      ;; Return an error message when it is a message call.
 422      (when (= dbus-message-type-method-call (nth 2 event))
 423        (dbus-ignore-errors
 424          (dbus-method-error-internal
 425           (nth 1 event) (nth 3 event) (nth 4 event) (cadr err))))
 426      ;; Propagate D-Bus error messages.
 427      (run-hook-with-args 'dbus-event-error-hooks event err)
 428      (when (or dbus-debug (= dbus-message-type-error (nth 2 event)))
 429        (signal (car err) (cdr err))))))
 430
 431 (defun dbus-event-bus-name (event)
 432   "Return the bus name the event is coming from.
 433 The result is either a Lisp symbol, `:system' or `:session', or a
 434 string denoting the bus address.  EVENT is a D-Bus event, see
 435 `dbus-check-event'.  This function raises a `dbus-error' signal
 436 in case the event is not well formed."
 437   (dbus-check-event event)
 438   (nth 1 event))
 439
 440 (defun dbus-event-message-type (event)
 441   "Return the message type of the corresponding D-Bus message.
 442 The result is a number.  EVENT is a D-Bus event, see
 443 `dbus-check-event'.  This function raises a `dbus-error' signal
 444 in case the event is not well formed."
 445   (dbus-check-event event)
 446   (nth 2 event))
 447
 448 (defun dbus-event-serial-number (event)
 449   "Return the serial number of the corresponding D-Bus message.
 450 The result is a number.  The serial number is needed for
 451 generating a reply message.  EVENT is a D-Bus event, see
 452 `dbus-check-event'.  This function raises a `dbus-error' signal
 453 in case the event is not well formed."
 454   (dbus-check-event event)
 455   (nth 3 event))
 456
 457 (defun dbus-event-service-name (event)
 458   "Return the name of the D-Bus object the event is coming from.
 459 The result is a string.  EVENT is a D-Bus event, see `dbus-check-event'.
 460 This function raises a `dbus-error' signal in case the event is
 461 not well formed."
 462   (dbus-check-event event)
 463   (nth 4 event))
 464
 465 (defun dbus-event-path-name (event)
 466   "Return the object path of the D-Bus object the event is coming from.
 467 The result is a string.  EVENT is a D-Bus event, see `dbus-check-event'.
 468 This function raises a `dbus-error' signal in case the event is
 469 not well formed."
 470   (dbus-check-event event)
 471   (nth 5 event))
 472
 473 (defun dbus-event-interface-name (event)
 474   "Return the interface name of the D-Bus object the event is coming from.
 475 The result is a string.  EVENT is a D-Bus event, see `dbus-check-event'.
 476 This function raises a `dbus-error' signal in case the event is
 477 not well formed."
 478   (dbus-check-event event)
 479   (nth 6 event))
 480
 481 (defun dbus-event-member-name (event)
 482   "Return the member name the event is coming from.
 483 It is either a signal name or a method name. The result is is a
 484 string.  EVENT is a D-Bus event, see `dbus-check-event'.  This
 485 function raises a `dbus-error' signal in case the event is not
 486 well formed."
 487   (dbus-check-event event)
 488   (nth 7 event))
 489
 490 \f
 491 ;;; D-Bus registered names.
 492
 493 (defun dbus-list-activatable-names ()
 494   "Return the D-Bus service names which can be activated as list.
 495 The result is a list of strings, which is `nil' when there are no
 496 activatable service names at all."
 497   (dbus-ignore-errors
 498     (dbus-call-method
 499      :system dbus-service-dbus
 500      dbus-path-dbus dbus-interface-dbus "ListActivatableNames")))
 501
 502 (defun dbus-list-names (bus)
 503   "Return the service names registered at D-Bus BUS.
 504 The result is a list of strings, which is `nil' when there are no
 505 registered service names at all.  Well known names are strings
 506 like \"org.freedesktop.DBus\".  Names starting with \":\" are
 507 unique names for services."
 508   (dbus-ignore-errors
 509     (dbus-call-method
 510      bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "ListNames")))
 511
 512 (defun dbus-list-known-names (bus)
 513   "Retrieve all services which correspond to a known name in BUS.
 514 A service has a known name if it doesn't start with \":\"."
 515   (let (result)
 516     (dolist (name (dbus-list-names bus) result)
 517       (unless (string-equal ":" (substring name 0 1))
 518         (add-to-list 'result name 'append)))))
 519
 520 (defun dbus-list-queued-owners (bus service)
 521   "Return the unique names registered at D-Bus BUS and queued for SERVICE.
 522 The result is a list of strings, or `nil' when there are no
 523 queued name owners service names at all."
 524   (dbus-ignore-errors
 525     (dbus-call-method
 526      bus dbus-service-dbus dbus-path-dbus
 527      dbus-interface-dbus "ListQueuedOwners" service)))
 528
 529 (defun dbus-get-name-owner (bus service)
 530   "Return the name owner of SERVICE registered at D-Bus BUS.
 531 The result is either a string, or `nil' if there is no name owner."
 532   (dbus-ignore-errors
 533     (dbus-call-method
 534      bus dbus-service-dbus dbus-path-dbus
 535      dbus-interface-dbus "GetNameOwner" service)))
 536
 537 (defun dbus-ping (bus service &optional timeout)
 538   "Check whether SERVICE is registered for D-Bus BUS.
 539 TIMEOUT, a nonnegative integer, specifies the maximum number of
 540 milliseconds `dbus-ping' must return.  The default value is 25,000.
 541
 542 Note, that this autoloads SERVICE if it is not running yet.  If
 543 it shall be checked whether SERVICE is already running, one shall
 544 apply
 545
 546   \(member service \(dbus-list-known-names bus))"
 547   ;; "Ping" raises a D-Bus error if SERVICE does not exist.
 548   ;; Otherwise, it returns silently with `nil'.
 549   (condition-case nil
 550       (not
 551        (if (natnump timeout)
 552            (dbus-call-method
 553             bus service dbus-path-dbus dbus-interface-peer
 554             "Ping" :timeout timeout)
 555          (dbus-call-method
 556           bus service dbus-path-dbus dbus-interface-peer "Ping")))
 557     (dbus-error nil)))
 558
 559 \f
 560 ;;; D-Bus introspection.
 561
 562 (defun dbus-introspect (bus service path)
 563   "Return all interfaces and sub-nodes of SERVICE,
 564 registered at object path PATH at bus BUS.
 565
 566 BUS is either a Lisp symbol, `:system' or `:session', or a string
 567 denoting the bus address.  SERVICE must be a known service name,
 568 and PATH must be a valid object path.  The last two parameters
 569 are strings.  The result, the introspection data, is a string in
 570 XML format."
 571   ;; We don't want to raise errors.  `dbus-call-method-non-blocking'
 572   ;; is used, because the handler can be registered in our Emacs
 573   ;; instance; caller an callee would block each other.
 574   (dbus-ignore-errors
 575     (funcall
 576      (if noninteractive 'dbus-call-method 'dbus-call-method-non-blocking)
 577      bus service path dbus-interface-introspectable "Introspect")))
 578
 579 (defun dbus-introspect-xml (bus service path)
 580   "Return the introspection data of SERVICE in D-Bus BUS at object path PATH.
 581 The data are a parsed list.  The root object is a \"node\",
 582 representing the object path PATH.  The root object can contain
 583 \"interface\" and further \"node\" objects."
 584   ;; We don't want to raise errors.
 585   (xml-node-name
 586    (ignore-errors
 587      (with-temp-buffer
 588        (insert (dbus-introspect bus service path))
 589        (xml-parse-region (point-min) (point-max))))))
 590
 591 (defun dbus-introspect-get-attribute (object attribute)
 592   "Return the ATTRIBUTE value of D-Bus introspection OBJECT.
 593 ATTRIBUTE must be a string according to the attribute names in
 594 the D-Bus specification."
 595   (xml-get-attribute-or-nil object (intern attribute)))
 596
 597 (defun dbus-introspect-get-node-names (bus service path)
 598   "Return all node names of SERVICE in D-Bus BUS at object path PATH.
 599 It returns a list of strings.  The node names stand for further
 600 object paths of the D-Bus service."
 601   (let ((object (dbus-introspect-xml bus service path))
 602         result)
 603     (dolist (elt (xml-get-children object 'node) result)
 604       (add-to-list
 605        'result (dbus-introspect-get-attribute elt "name") 'append))))
 606
 607 (defun dbus-introspect-get-all-nodes (bus service path)
 608   "Return all node names of SERVICE in D-Bus BUS at object path PATH.
 609 It returns a list of strings, which are further object paths of SERVICE."
 610   (let ((result (list path)))
 611     (dolist (elt
 612              (dbus-introspect-get-node-names bus service path)
 613              result)
 614       (setq elt (expand-file-name elt path))
 615       (setq result
 616             (append result (dbus-introspect-get-all-nodes bus service elt))))))
 617
 618 (defun dbus-introspect-get-interface-names (bus service path)
 619   "Return all interface names of SERVICE in D-Bus BUS at object path PATH.
 620 It returns a list of strings.
 621
 622 There will be always the default interface
 623 \"org.freedesktop.DBus.Introspectable\".  Another default
 624 interface is \"org.freedesktop.DBus.Properties\".  If present,
 625 \"interface\" objects can also have \"property\" objects as
 626 children, beside \"method\" and \"signal\" objects."
 627   (let ((object (dbus-introspect-xml bus service path))
 628         result)
 629     (dolist (elt (xml-get-children object 'interface) result)
 630       (add-to-list
 631        'result (dbus-introspect-get-attribute elt "name") 'append))))
 632
 633 (defun dbus-introspect-get-interface (bus service path interface)
 634   "Return the INTERFACE of SERVICE in D-Bus BUS at object path PATH.
 635 The return value is an XML object.  INTERFACE must be a string,
 636 element of the list returned by `dbus-introspect-get-interface-names'.
 637 The resulting \"interface\" object can contain \"method\", \"signal\",
 638 \"property\" and \"annotation\" children."
 639   (let ((elt (xml-get-children
 640               (dbus-introspect-xml bus service path) 'interface)))
 641     (while (and elt
 642                 (not (string-equal
 643                       interface
 644                       (dbus-introspect-get-attribute (car elt) "name"))))
 645       (setq elt (cdr elt)))
 646     (car elt)))
 647
 648 (defun dbus-introspect-get-method-names (bus service path interface)
 649   "Return a list of strings of all method names of INTERFACE.
 650 SERVICE is a service of D-Bus BUS at object path PATH."
 651   (let ((object (dbus-introspect-get-interface bus service path interface))
 652         result)
 653     (dolist (elt (xml-get-children object 'method) result)
 654       (add-to-list
 655        'result (dbus-introspect-get-attribute elt "name") 'append))))
 656
 657 (defun dbus-introspect-get-method (bus service path interface method)
 658   "Return method METHOD of interface INTERFACE as XML object.
 659 It must be located at SERVICE in D-Bus BUS at object path PATH.
 660 METHOD must be a string, element of the list returned by
 661 `dbus-introspect-get-method-names'.  The resulting \"method\"
 662 object can contain \"arg\" and \"annotation\" children."
 663   (let ((elt (xml-get-children
 664               (dbus-introspect-get-interface bus service path interface)
 665               'method)))
 666     (while (and elt
 667                 (not (string-equal
 668                       method (dbus-introspect-get-attribute (car elt) "name"))))
 669       (setq elt (cdr elt)))
 670     (car elt)))
 671
 672 (defun dbus-introspect-get-signal-names (bus service path interface)
 673   "Return a list of strings of all signal names of INTERFACE.
 674 SERVICE is a service of D-Bus BUS at object path PATH."
 675   (let ((object (dbus-introspect-get-interface bus service path interface))
 676         result)
 677     (dolist (elt (xml-get-children object 'signal) result)
 678       (add-to-list
 679        'result (dbus-introspect-get-attribute elt "name") 'append))))
 680
 681 (defun dbus-introspect-get-signal (bus service path interface signal)
 682   "Return signal SIGNAL of interface INTERFACE as XML object.
 683 It must be located at SERVICE in D-Bus BUS at object path PATH.
 684 SIGNAL must be a string, element of the list returned by
 685 `dbus-introspect-get-signal-names'.  The resulting \"signal\"
 686 object can contain \"arg\" and \"annotation\" children."
 687   (let ((elt (xml-get-children
 688               (dbus-introspect-get-interface bus service path interface)
 689               'signal)))
 690     (while (and elt
 691                 (not (string-equal
 692                       signal (dbus-introspect-get-attribute (car elt) "name"))))
 693       (setq elt (cdr elt)))
 694     (car elt)))
 695
 696 (defun dbus-introspect-get-property-names (bus service path interface)
 697   "Return a list of strings of all property names of INTERFACE.
 698 SERVICE is a service of D-Bus BUS at object path PATH."
 699   (let ((object (dbus-introspect-get-interface bus service path interface))
 700         result)
 701     (dolist (elt (xml-get-children object 'property) result)
 702       (add-to-list
 703        'result (dbus-introspect-get-attribute elt "name") 'append))))
 704
 705 (defun dbus-introspect-get-property (bus service path interface property)
 706   "This function returns PROPERTY of INTERFACE as XML object.
 707 It must be located at SERVICE in D-Bus BUS at object path PATH.
 708 PROPERTY must be a string, element of the list returned by
 709 `dbus-introspect-get-property-names'.  The resulting PROPERTY
 710 object can contain \"annotation\" children."
 711   (let ((elt (xml-get-children
 712               (dbus-introspect-get-interface bus service path interface)
 713               'property)))
 714     (while (and elt
 715                 (not (string-equal
 716                       property
 717                       (dbus-introspect-get-attribute (car elt) "name"))))
 718       (setq elt (cdr elt)))
 719     (car elt)))
 720
 721 (defun dbus-introspect-get-annotation-names
 722   (bus service path interface &optional name)
 723   "Return all annotation names as list of strings.
 724 If NAME is `nil', the annotations are children of INTERFACE,
 725 otherwise NAME must be a \"method\", \"signal\", or \"property\"
 726 object, where the annotations belong to."
 727   (let ((object
 728          (if name
 729              (or (dbus-introspect-get-method bus service path interface name)
 730                  (dbus-introspect-get-signal bus service path interface name)
 731                  (dbus-introspect-get-property bus service path interface name))
 732            (dbus-introspect-get-interface bus service path interface)))
 733         result)
 734     (dolist (elt (xml-get-children object 'annotation) result)
 735       (add-to-list
 736        'result (dbus-introspect-get-attribute elt "name") 'append))))
 737
 738 (defun dbus-introspect-get-annotation
 739   (bus service path interface name annotation)
 740   "Return ANNOTATION as XML object.
 741 If NAME is `nil', ANNOTATION is a child of INTERFACE, otherwise
 742 NAME must be the name of a \"method\", \"signal\", or
 743 \"property\" object, where the ANNOTATION belongs to."
 744   (let ((elt (xml-get-children
 745               (if name
 746                   (or (dbus-introspect-get-method
 747                        bus service path interface name)
 748                       (dbus-introspect-get-signal
 749                        bus service path interface name)
 750                       (dbus-introspect-get-property
 751                        bus service path interface name))
 752                 (dbus-introspect-get-interface bus service path interface))
 753               'annotation)))
 754     (while (and elt
 755                 (not (string-equal
 756                       annotation
 757                       (dbus-introspect-get-attribute (car elt) "name"))))
 758       (setq elt (cdr elt)))
 759     (car elt)))
 760
 761 (defun dbus-introspect-get-argument-names (bus service path interface name)
 762   "Return a list of all argument names as list of strings.
 763 NAME must be a \"method\" or \"signal\" object.
 764
 765 Argument names are optional, the function can return `nil'
 766 therefore, even if the method or signal has arguments."
 767   (let ((object
 768          (or (dbus-introspect-get-method bus service path interface name)
 769              (dbus-introspect-get-signal bus service path interface name)))
 770         result)
 771     (dolist (elt (xml-get-children object 'arg) result)
 772       (add-to-list
 773        'result (dbus-introspect-get-attribute elt "name") 'append))))
 774
 775 (defun dbus-introspect-get-argument (bus service path interface name arg)
 776   "Return argument ARG as XML object.
 777 NAME must be a \"method\" or \"signal\" object.  ARG must be a string,
 778 element of the list returned by `dbus-introspect-get-argument-names'."
 779   (let ((elt (xml-get-children
 780               (or (dbus-introspect-get-method bus service path interface name)
 781                   (dbus-introspect-get-signal bus service path interface name))
 782               'arg)))
 783     (while (and elt
 784                 (not (string-equal
 785                       arg (dbus-introspect-get-attribute (car elt) "name"))))
 786       (setq elt (cdr elt)))
 787     (car elt)))
 788
 789 (defun dbus-introspect-get-signature
 790   (bus service path interface name &optional direction)
 791   "Return signature of a `method' or `signal', represented by NAME, as string.
 792 If NAME is a `method', DIRECTION can be either \"in\" or \"out\".
 793 If DIRECTION is `nil', \"in\" is assumed.
 794
 795 If NAME is a `signal', and DIRECTION is non-`nil', DIRECTION must
 796 be \"out\"."
 797   ;; For methods, we use "in" as default direction.
 798   (let ((object (or (dbus-introspect-get-method
 799                      bus service path interface name)
 800                     (dbus-introspect-get-signal
 801                      bus service path interface name))))
 802     (when (and (string-equal
 803                 "method" (dbus-introspect-get-attribute object "name"))
 804                (not (stringp direction)))
 805       (setq direction "in"))
 806     ;; In signals, no direction is given.
 807     (when (string-equal "signal" (dbus-introspect-get-attribute object "name"))
 808       (setq direction nil))
 809     ;; Collect the signatures.
 810     (mapconcat
 811      '(lambda (x)
 812         (let ((arg (dbus-introspect-get-argument
 813                     bus service path interface name x)))
 814           (if (or (not (stringp direction))
 815                   (string-equal
 816                    direction
 817                    (dbus-introspect-get-attribute arg "direction")))
 818               (dbus-introspect-get-attribute arg "type")
 819             "")))
 820      (dbus-introspect-get-argument-names bus service path interface name)
 821      "")))
 822
 823 \f
 824 ;;; D-Bus properties.
 825
 826 (defun dbus-get-property (bus service path interface property)
 827   "Return the value of PROPERTY of INTERFACE.
 828 It will be checked at BUS, SERVICE, PATH.  The result can be any
 829 valid D-Bus value, or `nil' if there is no PROPERTY."
 830   (dbus-ignore-errors
 831     ;; "Get" returns a variant, so we must use the `car'.
 832     (car
 833      (funcall
 834       (if noninteractive 'dbus-call-method 'dbus-call-method-non-blocking)
 835       bus service path dbus-interface-properties
 836       "Get" :timeout 500 interface property))))
 837
 838 (defun dbus-set-property (bus service path interface property value)
 839   "Set value of PROPERTY of INTERFACE to VALUE.
 840 It will be checked at BUS, SERVICE, PATH.  When the value has
 841 been set successful, the result is VALUE.  Otherwise, `nil' is
 842 returned."
 843   (dbus-ignore-errors
 844     ;; "Set" requires a variant.
 845     (funcall
 846      (if noninteractive 'dbus-call-method 'dbus-call-method-non-blocking)
 847      bus service path dbus-interface-properties
 848      "Set" :timeout 500 interface property (list :variant value))
 849     ;; Return VALUE.
 850     (dbus-get-property bus service path interface property)))
 851
 852 (defun dbus-get-all-properties (bus service path interface)
 853   "Return all properties of INTERFACE at BUS, SERVICE, PATH.
 854 The result is a list of entries.  Every entry is a cons of the
 855 name of the property, and its value.  If there are no properties,
 856 `nil' is returned."
 857   (dbus-ignore-errors
 858     ;; "GetAll" returns "a{sv}".
 859     (let (result)
 860       (dolist (dict
 861                (funcall
 862                 (if noninteractive
 863                     'dbus-call-method
 864                   'dbus-call-method-non-blocking)
 865                 bus service path dbus-interface-properties
 866                 "GetAll" :timeout 500 interface)
 867                result)
 868         (add-to-list 'result (cons (car dict) (caadr dict)) 'append)))))
 869
 870 (defun dbus-register-property
 871   (bus service path interface property access value &optional emits-signal)
 872   "Register property PROPERTY on the D-Bus BUS.
 873
 874 BUS is either a Lisp symbol, `:system' or `:session', or a string
 875 denoting the bus address.
 876
 877 SERVICE is the D-Bus service name of the D-Bus.  It must be a
 878 known name.
 879
 880 PATH is the D-Bus object path SERVICE is registered.  INTERFACE
 881 is the name of the interface used at PATH, PROPERTY is the name
 882 of the property of INTERFACE.  ACCESS indicates, whether the
 883 property can be changed by other services via D-Bus.  It must be
 884 either the symbol `:read' or `:readwrite'.  VALUE is the initial
 885 value of the property, it can be of any valid type (see
 886 `dbus-call-method' for details).
 887
 888 If PROPERTY already exists on PATH, it will be overwritten.  For
 889 properties with access type `:read' this is the only way to
 890 change their values.  Properties with access type `:readwrite'
 891 can be changed by `dbus-set-property'.
 892
 893 The interface \"org.freedesktop.DBus.Properties\" is added to
 894 PATH, including a default handler for the \"Get\", \"GetAll\" and
 895 \"Set\" methods of this interface.  When EMITS-SIGNAL is non-nil,
 896 the signal \"PropertiesChanged\" is sent when the property is
 897 changed by `dbus-set-property'."
 898   (unless (member access '(:read :readwrite))
 899     (signal 'dbus-error (list "Access type invalid" access)))
 900
 901   ;; Register SERVICE.
 902   (unless (member service (dbus-list-names bus))
 903     (dbus-call-method
 904      bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus
 905      "RequestName" service 0))
 906
 907   ;; Add the handler.  We use `dbus-service-emacs' as service name, in
 908   ;; order to let unregister SERVICE despite of this default handler.
 909   (dbus-register-method
 910    bus service path dbus-interface-properties "Get" 'dbus-property-handler)
 911   (dbus-register-method
 912    bus service path dbus-interface-properties "GetAll" 'dbus-property-handler)
 913   (dbus-register-method
 914    bus service path dbus-interface-properties "Set" 'dbus-property-handler)
 915
 916   ;; Send the PropertiesChanged signal.
 917   (when emits-signal
 918     (dbus-send-signal
 919      bus service path dbus-interface-properties "PropertiesChanged"
 920      (list (list :dict-entry property (list :variant value)))
 921      '(:array)))
 922
 923   ;; Create a hash table entry.  We use nil for the unique name,
 924   ;; because the property might be accessed from anybody.
 925   (let ((key (list bus interface property))
 926         (val
 927          (list
 928           (list
 929            nil service path
 930            (cons
 931             (if emits-signal (list access :emits-signal) (list access))
 932             value)))))
 933     (puthash key val dbus-registered-objects-table)
 934
 935     ;; Return the object.
 936     (list key (list service path))))
 937
 938 (defun dbus-property-handler (&rest args)
 939   "Default handler for the \"org.freedesktop.DBus.Properties\" interface.
 940 It will be registered for all objects created by `dbus-register-object'."
 941   (let ((bus (dbus-event-bus-name last-input-event))
 942         (service (dbus-event-service-name last-input-event))
 943         (path (dbus-event-path-name last-input-event))
 944         (method (dbus-event-member-name last-input-event))
 945         (interface (car args))
 946         (property (cadr args)))
 947     (cond
 948      ;; "Get" returns a variant.
 949      ((string-equal method "Get")
 950       (let ((entry (gethash (list bus interface property)
 951                             dbus-registered-objects-table)))
 952         (when (string-equal path (nth 2 (car entry)))
 953           (list (list :variant (cdar (last (car entry))))))))
 954
 955      ;; "Set" expects a variant.
 956      ((string-equal method "Set")
 957       (let* ((value (caar (cddr args)))
 958              (entry (gethash (list bus interface property)
 959                              dbus-registered-objects-table))
 960              ;; The value of the hash table is a list; in case of
 961              ;; properties it contains just one element (UNAME SERVICE
 962              ;; PATH OBJECT).  OBJECT is a cons cell of a list, which
 963              ;; contains a list of annotations (like :read,
 964              ;; :read-write, :emits-signal), and the value of the
 965              ;; property.
 966              (object (car (last (car entry)))))
 967         (unless (consp object)
 968           (signal 'dbus-error
 969                   (list "Property not registered at path" property path)))
 970         (unless (member :readwrite (car object))
 971           (signal 'dbus-error
 972                   (list "Property not writable at path" property path)))
 973         (puthash (list bus interface property)
 974                  (list (append (butlast (car entry))
 975                                (list (cons (car object) value))))
 976                  dbus-registered-objects-table)
 977         ;; Send the "PropertiesChanged" signal.
 978         (when (member :emits-signal (car object))
 979           (dbus-send-signal
 980            bus service path dbus-interface-properties "PropertiesChanged"
 981            (list (list :dict-entry property (list :variant value)))
 982            '(:array)))
 983         ;; Return empty reply.
 984         :ignore))
 985
 986      ;; "GetAll" returns "a{sv}".
 987      ((string-equal method "GetAll")
 988       (let (result)
 989         (maphash
 990          (lambda (key val)
 991            (when (and (equal (butlast key) (list bus interface))
 992                       (string-equal path (nth 2 (car val)))
 993                       (not (functionp (car (last (car val))))))
 994              (add-to-list
 995               'result
 996               (list :dict-entry
 997                     (car (last key))
 998                     (list :variant (cdar (last (car val))))))))
 999          dbus-registered-objects-table)
1000         (list result))))))
1001
1002  \f
1003 ;; Initialize :system and :session buses.  This adds their file
1004 ;; descriptors to input_wait_mask, in order to detect incoming
1005 ;; messages immediately.
1006 (when (featurep 'dbusbind)
1007   (dbus-ignore-errors
1008     (dbus-init-bus :system)
1009     (dbus-init-bus :session)))
1010
1011 (provide 'dbus)
1012
1013 ;; arch-tag: a47caf84-9162-4811-90cc-5d388e37b9bd
1014 ;;; dbus.el ends here