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