lisp/net/dbus.el

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