| 1 | ;;; -*- no-byte-compile: t; -*- |
| 2 | ;;; dbus.el --- Elisp bindings for D-Bus. |
| 3 | |
| 4 | ;; Copyright (C) 2007 Free Software Foundation, Inc. |
| 5 | |
| 6 | ;; Author: Michael Albinus <michael.albinus@gmx.de> |
| 7 | ;; Keywords: comm, hardware |
| 8 | |
| 9 | ;; This file is part of GNU Emacs. |
| 10 | |
| 11 | ;; GNU Emacs is free software; you can redistribute it and/or modify |
| 12 | ;; it under the terms of the GNU General Public License as published by |
| 13 | ;; the Free Software Foundation; either version 3, or (at your option) |
| 14 | ;; any later version. |
| 15 | |
| 16 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 19 | ;; GNU General Public License for more details. |
| 20 | |
| 21 | ;; You should have received a copy of the GNU General Public License |
| 22 | ;; along with GNU Emacs; see the file COPYING. If not, see |
| 23 | ;; <http://www.gnu.org/licenses/>. |
| 24 | |
| 25 | ;;; Commentary: |
| 26 | |
| 27 | ;; This package provides language bindings for the D-Bus API. D-Bus |
| 28 | ;; is a message bus system, a simple way for applications to talk to |
| 29 | ;; one another. See <http://dbus.freedesktop.org/> for details. |
| 30 | |
| 31 | ;; Low-level language bindings are implemented in src/dbusbind.c. |
| 32 | |
| 33 | ;;; Code: |
| 34 | |
| 35 | (require 'xml) |
| 36 | |
| 37 | (defconst dbus-service-dbus "org.freedesktop.DBus" |
| 38 | "The bus name used to talk to the bus itself.") |
| 39 | |
| 40 | (defconst dbus-path-dbus "/org/freedesktop/DBus" |
| 41 | "The object path used to talk to the bus itself.") |
| 42 | |
| 43 | (defconst dbus-interface-dbus "org.freedesktop.DBus" |
| 44 | "The interface exported by the object with `dbus-service-dbus' and `dbus-path-dbus'.") |
| 45 | |
| 46 | (defconst dbus-interface-introspectable "org.freedesktop.DBus.Introspectable" |
| 47 | "The interface supported by introspectable objects.") |
| 48 | |
| 49 | \f |
| 50 | ;;; Hash table of registered functions. |
| 51 | |
| 52 | (defun dbus-hash-table= (x y) |
| 53 | "Compares keys X and Y in the hash table of registered functions for D-Bus. |
| 54 | See `dbus-registered-functions-table' for a description of the hash table." |
| 55 | (and |
| 56 | ;; Bus symbol, either :system or :session. |
| 57 | (equal (car x) (car y)) |
| 58 | ;; Service. |
| 59 | (or |
| 60 | (null (nth 1 x)) (null (nth 1 y)) ; wildcard |
| 61 | (string-equal (nth 1 x) (nth 1 y))) |
| 62 | ;; Path. |
| 63 | (or |
| 64 | (null (nth 2 x)) (null (nth 2 y)) ; wildcard |
| 65 | (string-equal (nth 2 x) (nth 2 y))) |
| 66 | ;; Member. |
| 67 | (or |
| 68 | (null (nth 3 x)) (null (nth 3 y)) ; wildcard |
| 69 | (string-equal (nth 3 x) (nth 3 y))) |
| 70 | ;; Interface. |
| 71 | (or |
| 72 | (null (nth 4 x)) (null (nth 4 y)) ; wildcard |
| 73 | (string-equal (nth 4 x) (nth 4 y))))) |
| 74 | |
| 75 | (define-hash-table-test 'dbus-hash-table-test 'dbus-hash-table= 'sxhash) |
| 76 | |
| 77 | ;; When we assume that service, path, interface and and member are |
| 78 | ;; always strings in the key, we could use `equal' as test function. |
| 79 | ;; But we want to have also `nil' there, being a wildcard. |
| 80 | (setq dbus-registered-functions-table |
| 81 | (make-hash-table :test 'dbus-hash-table-test)) |
| 82 | |
| 83 | (defun dbus-list-hash-table () |
| 84 | "Returns all registered signal registrations to D-Bus. |
| 85 | The return value is a list, with elements of kind (KEY . VALUE). |
| 86 | See `dbus-registered-functions-table' for a description of the |
| 87 | hash table." |
| 88 | (let (result) |
| 89 | (maphash |
| 90 | '(lambda (key value) (add-to-list 'result (cons key value) 'append)) |
| 91 | dbus-registered-functions-table) |
| 92 | result)) |
| 93 | |
| 94 | (defun dbus-name-owner-changed-handler (service old-owner new-owner) |
| 95 | "Reapplies all signal registrations to D-Bus. |
| 96 | This handler is applied when a \"NameOwnerChanged\" signal has |
| 97 | arrived. SERVICE is the object name for which the name owner has |
| 98 | been changed. OLD-OWNER is the previous owner of SERVICE, or the |
| 99 | empty string if SERVICE was not owned yet. NEW-OWNER is the new |
| 100 | owner of SERVICE, or the empty string if SERVICE looses any name owner." |
| 101 | (save-match-data |
| 102 | ;; Check whether SERVICE is a known name, and OLD-OWNER and |
| 103 | ;; NEW-OWNER are defined. |
| 104 | (when (and (stringp service) (not (string-match "^:" service)) |
| 105 | (not (zerop (length old-owner))) |
| 106 | (not (zerop (length new-owner)))) |
| 107 | (let ((bus (dbus-event-bus-name last-input-event))) |
| 108 | (maphash |
| 109 | '(lambda (key value) |
| 110 | ;; Check for matching bus and service name. |
| 111 | (when (and (equal bus (car key)) |
| 112 | (string-equal old-owner (nth 1 key))) |
| 113 | ;; Remove old key, and add new entry with changed name. |
| 114 | (when dbus-debug (message "Remove rule for %s" key)) |
| 115 | (dbus-unregister-signal key) |
| 116 | (setcar (nthcdr 1 key) new-owner) |
| 117 | (when dbus-debug (message "Add rule for %s" key)) |
| 118 | (apply 'dbus-register-signal (append key (list value))))) |
| 119 | (copy-hash-table dbus-registered-functions-table)))))) |
| 120 | |
| 121 | ;; Register the handler. |
| 122 | (condition-case nil |
| 123 | (progn |
| 124 | (dbus-register-signal |
| 125 | :system dbus-service-dbus dbus-path-dbus dbus-interface-dbus |
| 126 | "NameOwnerChanged" 'dbus-name-owner-changed-handler) |
| 127 | (dbus-register-signal |
| 128 | :session dbus-service-dbus dbus-path-dbus dbus-interface-dbus |
| 129 | "NameOwnerChanged" 'dbus-name-owner-changed-handler)) |
| 130 | (dbus-error)) |
| 131 | |
| 132 | \f |
| 133 | ;;; D-Bus events. |
| 134 | |
| 135 | (defun dbus-check-event (event) |
| 136 | "Checks whether EVENT is a well formed D-Bus event. |
| 137 | EVENT is a list which starts with symbol `dbus-event': |
| 138 | |
| 139 | (dbus-event BUS SERVICE PATH INTERFACE MEMBER HANDLER &rest ARGS) |
| 140 | |
| 141 | BUS identifies the D-Bus the signal is coming from. It is either |
| 142 | the symbol `:system' or the symbol `:session'. SERVICE and PATH |
| 143 | are the unique name and the object path of the D-Bus object |
| 144 | emitting the signal. INTERFACE and MEMBER denote the signal |
| 145 | which has been sent. HANDLER is the function which has been |
| 146 | registered for this signal. ARGS are the arguments passed to |
| 147 | HANDLER, when it is called during event handling in |
| 148 | `dbus-handle-event'. |
| 149 | |
| 150 | This function raises a `dbus-error' signal in case the event is |
| 151 | not well formed." |
| 152 | (when dbus-debug (message "DBus-Event %s" event)) |
| 153 | (unless (and (listp event) |
| 154 | (eq (car event) 'dbus-event) |
| 155 | ;; Bus symbol. |
| 156 | (symbolp (nth 1 event)) |
| 157 | ;; Service. |
| 158 | (stringp (nth 2 event)) |
| 159 | ;; Object path. |
| 160 | (stringp (nth 3 event)) |
| 161 | ;; Interface. |
| 162 | (stringp (nth 4 event)) |
| 163 | ;; Member. |
| 164 | (stringp (nth 5 event)) |
| 165 | ;; Handler. |
| 166 | (functionp (nth 6 event))) |
| 167 | (signal 'dbus-error (list "Not a valid D-Bus event" event)))) |
| 168 | |
| 169 | ;;;###autoload |
| 170 | (defun dbus-handle-event (event) |
| 171 | "Handle events from the D-Bus. |
| 172 | EVENT is a D-Bus event, see `dbus-check-event'. HANDLER, being |
| 173 | part of the event, is called with arguments ARGS." |
| 174 | (interactive "e") |
| 175 | ;; We don't want to raise an error, because this function is called |
| 176 | ;; in the event handling loop. |
| 177 | (condition-case nil |
| 178 | (progn |
| 179 | (dbus-check-event event) |
| 180 | (apply (nth 6 event) (nthcdr 7 event))) |
| 181 | (dbus-error))) |
| 182 | |
| 183 | (defun dbus-event-bus-name (event) |
| 184 | "Return the bus name the event is coming from. |
| 185 | The result is either the symbol `:system' or the symbol `:session'. |
| 186 | EVENT is a D-Bus event, see `dbus-check-event'. This function |
| 187 | raises a `dbus-error' signal in case the event is not well |
| 188 | formed." |
| 189 | (dbus-check-event event) |
| 190 | (nth 1 event)) |
| 191 | |
| 192 | (defun dbus-event-service-name (event) |
| 193 | "Return the name of the D-Bus object the event is coming from. |
| 194 | The result is a string. EVENT is a D-Bus event, see `dbus-check-event'. |
| 195 | This function raises a `dbus-error' signal in case the event is |
| 196 | not well formed." |
| 197 | (dbus-check-event event) |
| 198 | (nth 2 event)) |
| 199 | |
| 200 | (defun dbus-event-path-name (event) |
| 201 | "Return the object path of the D-Bus object the event is coming from. |
| 202 | The result is a string. EVENT is a D-Bus event, see `dbus-check-event'. |
| 203 | This function raises a `dbus-error' signal in case the event is |
| 204 | not well formed." |
| 205 | (dbus-check-event event) |
| 206 | (nth 3 event)) |
| 207 | |
| 208 | (defun dbus-event-interface-name (event) |
| 209 | "Return the interface name of the D-Bus object the event is coming from. |
| 210 | The result is a string. EVENT is a D-Bus event, see `dbus-check-event'. |
| 211 | This function raises a `dbus-error' signal in case the event is |
| 212 | not well formed." |
| 213 | (dbus-check-event event) |
| 214 | (nth 4 event)) |
| 215 | |
| 216 | (defun dbus-event-member-name (event) |
| 217 | "Return the member name the event is coming from. |
| 218 | It is either a signal name or a method name. The result is is a |
| 219 | string. EVENT is a D-Bus event, see `dbus-check-event'. This |
| 220 | function raises a `dbus-error' signal in case the event is not |
| 221 | well formed." |
| 222 | (dbus-check-event event) |
| 223 | (nth 5 event)) |
| 224 | |
| 225 | \f |
| 226 | ;;; D-Bus registered names. |
| 227 | |
| 228 | (defun dbus-list-activatable-names () |
| 229 | "Return the D-Bus service names which can be activated as list. |
| 230 | The result is a list of strings, which is nil when there are no |
| 231 | activatable service names at all." |
| 232 | (condition-case nil |
| 233 | (dbus-call-method |
| 234 | :system dbus-service-dbus |
| 235 | dbus-path-dbus dbus-interface-dbus "ListActivatableNames") |
| 236 | (dbus-error))) |
| 237 | |
| 238 | (defun dbus-list-names (bus) |
| 239 | "Return the service names registered at D-Bus BUS. |
| 240 | The result is a list of strings, which is nil when there are no |
| 241 | registered service names at all. Well known names are strings like |
| 242 | \"org.freedesktop.DBus\". Names starting with \":\" are unique names |
| 243 | for services." |
| 244 | (condition-case nil |
| 245 | (dbus-call-method |
| 246 | bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "ListNames") |
| 247 | (dbus-error))) |
| 248 | |
| 249 | (defun dbus-list-known-names (bus) |
| 250 | "Retrieve all services which correspond to a known name in BUS. |
| 251 | A service has a known name if it doesn't start with \":\"." |
| 252 | (let (result) |
| 253 | (dolist (name (dbus-list-names bus) result) |
| 254 | (unless (string-equal ":" (substring name 0 1)) |
| 255 | (add-to-list 'result name 'append))))) |
| 256 | |
| 257 | (defun dbus-list-queued-owners (bus service) |
| 258 | "Return the unique names registered at D-Bus BUS and queued for SERVICE. |
| 259 | The result is a list of strings, or nil when there are no queued name |
| 260 | owners service names at all." |
| 261 | (condition-case nil |
| 262 | (dbus-call-method |
| 263 | bus dbus-service-dbus dbus-path-dbus |
| 264 | dbus-interface-dbus "ListQueuedOwners" service) |
| 265 | (dbus-error))) |
| 266 | |
| 267 | (defun dbus-get-name-owner (bus service) |
| 268 | "Return the name owner of SERVICE registered at D-Bus BUS. |
| 269 | The result is either a string, or nil if there is no name owner." |
| 270 | (condition-case nil |
| 271 | (dbus-call-method |
| 272 | bus dbus-service-dbus dbus-path-dbus |
| 273 | dbus-interface-dbus "GetNameOwner" service) |
| 274 | (dbus-error))) |
| 275 | |
| 276 | (defun dbus-introspect (bus service path) |
| 277 | "Return the introspection data of SERVICE in D-Bus BUS at object path PATH. |
| 278 | The data are in XML format. |
| 279 | |
| 280 | Example: |
| 281 | |
| 282 | \(dbus-introspect |
| 283 | :system \"org.freedesktop.Hal\" |
| 284 | \"/org/freedesktop/Hal/devices/computer\")" |
| 285 | (condition-case nil |
| 286 | (dbus-call-method |
| 287 | bus service path dbus-interface-introspectable "Introspect") |
| 288 | (dbus-error))) |
| 289 | |
| 290 | (if nil ;; Must be reworked. Shall we offer D-Bus signatures at all? |
| 291 | (defun dbus-get-signatures (bus interface signal) |
| 292 | "Retrieve SIGNAL's type signatures from D-Bus. |
| 293 | The result is a list of SIGNAL's type signatures. Example: |
| 294 | |
| 295 | \(\"s\" \"b\" \"ai\"\) |
| 296 | |
| 297 | This list represents 3 parameters of SIGNAL. The first parameter |
| 298 | is of type string, the second parameter is of type boolean, and |
| 299 | the third parameter is of type array of integer. |
| 300 | |
| 301 | If INTERFACE or SIGNAL do not exist, or if they do not support |
| 302 | the D-Bus method org.freedesktop.DBus.Introspectable.Introspect, |
| 303 | the function returns nil." |
| 304 | (condition-case nil |
| 305 | (let ((introspect-xml |
| 306 | (with-temp-buffer |
| 307 | (insert (dbus-introspect bus interface)) |
| 308 | (xml-parse-region (point-min) (point-max)))) |
| 309 | node interfaces signals args result) |
| 310 | ;; Get the root node. |
| 311 | (setq node (xml-node-name introspect-xml)) |
| 312 | ;; Get all interfaces. |
| 313 | (setq interfaces (xml-get-children node 'interface)) |
| 314 | (while interfaces |
| 315 | (when (string-equal (xml-get-attribute (car interfaces) 'name) |
| 316 | interface) |
| 317 | ;; That's the requested interface. Check for signals. |
| 318 | (setq signals (xml-get-children (car interfaces) 'signal)) |
| 319 | (while signals |
| 320 | (when (string-equal (xml-get-attribute (car signals) 'name) |
| 321 | signal) |
| 322 | ;; The signal we are looking for. |
| 323 | (setq args (xml-get-children (car signals) 'arg)) |
| 324 | (while args |
| 325 | (unless (xml-get-attribute (car args) 'type) |
| 326 | ;; This shouldn't happen, let's escape. |
| 327 | (signal 'dbus-error "")) |
| 328 | ;; We append the signature. |
| 329 | (setq |
| 330 | result (append result |
| 331 | (list (xml-get-attribute (car args) 'type)))) |
| 332 | (setq args (cdr args))) |
| 333 | (setq signals nil)) |
| 334 | (setq signals (cdr signals))) |
| 335 | (setq interfaces nil)) |
| 336 | (setq interfaces (cdr interfaces))) |
| 337 | result) |
| 338 | ;; We ignore `dbus-error'. There might be no introspectable interface. |
| 339 | (dbus-error nil))) |
| 340 | ) ;; (if nil ... |
| 341 | |
| 342 | (provide 'dbus) |
| 343 | |
| 344 | ;; arch-tag: a47caf84-9162-4811-90cc-5d388e37b9bd |
| 345 | ;;; dbus.el ends here |