cgit.sxemacs.org Git - sxemacs/blob - modules/dbus/dbus.el

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