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