Commit | Line | Data |
---|---|---|
3a993e3d MA |
1 | ;;; dbus.el --- Elisp bindings for D-Bus. |
2 | ||
acaf905b | 3 | ;; Copyright (C) 2007-2012 Free Software Foundation, Inc. |
3a993e3d MA |
4 | |
5 | ;; Author: Michael Albinus <michael.albinus@gmx.de> | |
6 | ;; Keywords: comm, hardware | |
7 | ||
8 | ;; This file is part of GNU Emacs. | |
9 | ||
874a927a | 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
3a993e3d | 11 | ;; it under the terms of the GNU General Public License as published by |
874a927a GM |
12 | ;; the Free Software Foundation, either version 3 of the License, or |
13 | ;; (at your option) any later version. | |
3a993e3d MA |
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 | |
874a927a | 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
3a993e3d MA |
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 | ||
7bb7efbd | 33 | ;; D-Bus support in the Emacs core can be disabled with configuration |
6981d00a MA |
34 | ;; option "--without-dbus". Declare used subroutines and variables. |
35 | (declare-function dbus-call-method "dbusbind.c") | |
52a39a64 | 36 | (declare-function dbus-call-method-asynchronously "dbusbind.c") |
ba6f7d86 | 37 | (declare-function dbus-init-bus "dbusbind.c") |
5e895c06 MA |
38 | (declare-function dbus-method-return-internal "dbusbind.c") |
39 | (declare-function dbus-method-error-internal "dbusbind.c") | |
4d6769e1 | 40 | (declare-function dbus-register-service "dbusbind.c") |
6981d00a | 41 | (declare-function dbus-register-signal "dbusbind.c") |
35b148ee | 42 | (declare-function dbus-register-method "dbusbind.c") |
b24344ca | 43 | (declare-function dbus-send-signal "dbusbind.c") |
6981d00a | 44 | (defvar dbus-debug) |
b172ed20 | 45 | (defvar dbus-registered-objects-table) |
6981d00a MA |
46 | |
47 | ;; Pacify byte compiler. | |
48 | (eval-when-compile | |
49 | (require 'cl)) | |
7bb7efbd | 50 | |
3a993e3d MA |
51 | (require 'xml) |
52 | ||
53 | (defconst dbus-service-dbus "org.freedesktop.DBus" | |
54 | "The bus name used to talk to the bus itself.") | |
55 | ||
56 | (defconst dbus-path-dbus "/org/freedesktop/DBus" | |
57 | "The object path used to talk to the bus itself.") | |
58 | ||
59 | (defconst dbus-interface-dbus "org.freedesktop.DBus" | |
60 | "The interface exported by the object with `dbus-service-dbus' and `dbus-path-dbus'.") | |
61 | ||
4ba11bcb MA |
62 | (defconst dbus-interface-peer (concat dbus-interface-dbus ".Peer") |
63 | "The interface for peer objects.") | |
64 | ||
65 | (defconst dbus-interface-introspectable | |
66 | (concat dbus-interface-dbus ".Introspectable") | |
3a993e3d MA |
67 | "The interface supported by introspectable objects.") |
68 | ||
f636d3ca MA |
69 | (defconst dbus-interface-properties (concat dbus-interface-dbus ".Properties") |
70 | "The interface for property objects.") | |
71 | ||
65b7cb2c MA |
72 | (defconst dbus-service-emacs "org.gnu.Emacs" |
73 | "The well known service name of Emacs.") | |
74 | ||
75 | (defconst dbus-path-emacs "/org/gnu/Emacs" | |
76 | "The object path head used by Emacs.") | |
77 | ||
98c38bfc MA |
78 | (defconst dbus-message-type-invalid 0 |
79 | "This value is never a valid message type.") | |
80 | ||
81 | (defconst dbus-message-type-method-call 1 | |
82 | "Message type of a method call message.") | |
83 | ||
84 | (defconst dbus-message-type-method-return 2 | |
85 | "Message type of a method return message.") | |
86 | ||
87 | (defconst dbus-message-type-error 3 | |
88 | "Message type of an error reply message.") | |
89 | ||
90 | (defconst dbus-message-type-signal 4 | |
91 | "Message type of a signal message.") | |
92 | ||
246a286b MA |
93 | (defmacro dbus-ignore-errors (&rest body) |
94 | "Execute BODY; signal D-Bus error when `dbus-debug' is non-nil. | |
95 | Otherwise, return result of last form in BODY, or all other errors." | |
f291fe60 | 96 | (declare (indent 0) (debug t)) |
246a286b MA |
97 | `(condition-case err |
98 | (progn ,@body) | |
99 | (dbus-error (when dbus-debug (signal (car err) (cdr err)))))) | |
246a286b MA |
100 | (font-lock-add-keywords 'emacs-lisp-mode '("\\<dbus-ignore-errors\\>")) |
101 | ||
e12c189f MA |
102 | (defvar dbus-event-error-hooks nil |
103 | "Functions to be called when a D-Bus error happens in the event handler. | |
f213fc09 | 104 | Every function must accept two arguments, the event and the error variable |
333f9019 | 105 | caught in `condition-case' by `dbus-error'.") |
e12c189f | 106 | |
5363d8ea MA |
107 | \f |
108 | ;;; Hash table of registered functions. | |
109 | ||
98c38bfc MA |
110 | (defvar dbus-return-values-table (make-hash-table :test 'equal) |
111 | "Hash table for temporary storing arguments of reply messages. | |
e73f184c MA |
112 | A key in this hash table is a list (BUS SERIAL). BUS is either a |
113 | Lisp symbol, `:system' or `:session', or a string denoting the | |
114 | bus address. SERIAL is the serial number of the reply message. | |
115 | See `dbus-call-method-non-blocking-handler' and | |
98c38bfc MA |
116 | `dbus-call-method-non-blocking'.") |
117 | ||
ef6ce14c | 118 | (defun dbus-list-hash-table () |
e49d337b | 119 | "Returns all registered member registrations to D-Bus. |
ef6ce14c | 120 | The return value is a list, with elements of kind (KEY . VALUE). |
b172ed20 | 121 | See `dbus-registered-objects-table' for a description of the |
ef6ce14c MA |
122 | hash table." |
123 | (let (result) | |
124 | (maphash | |
4f91a816 | 125 | (lambda (key value) (add-to-list 'result (cons key value) 'append)) |
b172ed20 | 126 | dbus-registered-objects-table) |
ef6ce14c MA |
127 | result)) |
128 | ||
246a286b MA |
129 | (defun dbus-unregister-object (object) |
130 | "Unregister OBJECT from D-Bus. | |
b172ed20 MA |
131 | OBJECT must be the result of a preceding `dbus-register-method', |
132 | `dbus-register-property' or `dbus-register-signal' call. It | |
133 | returns `t' if OBJECT has been unregistered, `nil' otherwise. | |
134 | ||
135 | When OBJECT identifies the last method or property, which is | |
136 | registered for the respective service, Emacs releases its | |
137 | association to the service from D-Bus." | |
246a286b MA |
138 | ;; Check parameter. |
139 | (unless (and (consp object) (not (null (car object))) (consp (cdr object))) | |
140 | (signal 'wrong-type-argument (list 'D-Bus object))) | |
141 | ||
142 | ;; Find the corresponding entry in the hash table. | |
143 | (let* ((key (car object)) | |
e2ee6f30 MA |
144 | (value (cadr object)) |
145 | (bus (car key)) | |
146 | (service (car value)) | |
b172ed20 | 147 | (entry (gethash key dbus-registered-objects-table)) |
8fb1629f | 148 | ret) |
f6b1b0a8 | 149 | ;; key has the structure (BUS INTERFACE MEMBER). |
e2ee6f30 | 150 | ;; value has the structure (SERVICE PATH [HANDLER]). |
fac7ae53 | 151 | ;; entry has the structure ((UNAME SERVICE PATH MEMBER [RULE]) ...). |
b172ed20 MA |
152 | ;; MEMBER is either a string (the handler), or a cons cell (a |
153 | ;; property value). UNAME and property values are not taken into | |
b0b19974 | 154 | ;; account for comparison. |
b172ed20 | 155 | |
246a286b | 156 | ;; Loop over the registered functions. |
b172ed20 MA |
157 | (dolist (elt entry) |
158 | (when (equal | |
e2ee6f30 MA |
159 | value |
160 | (butlast (cdr elt) (- (length (cdr elt)) (length value)))) | |
fac7ae53 | 161 | (setq ret t) |
b172ed20 | 162 | ;; Compute new hash value. If it is empty, remove it from the |
246a286b | 163 | ;; hash table. |
b172ed20 MA |
164 | (unless (puthash key (delete elt entry) dbus-registered-objects-table) |
165 | (remhash key dbus-registered-objects-table)) | |
fac7ae53 MA |
166 | ;; Remove match rule of signals. |
167 | (let ((rule (nth 4 elt))) | |
168 | (when (stringp rule) | |
e2ee6f30 | 169 | (setq service nil) ; We do not need to unregister the service. |
fac7ae53 | 170 | (dbus-call-method |
e2ee6f30 | 171 | bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus |
fac7ae53 | 172 | "RemoveMatch" rule))))) |
b172ed20 MA |
173 | ;; Check, whether there is still a registered function or property |
174 | ;; for the given service. If not, unregister the service from the | |
175 | ;; bus. | |
e2ee6f30 MA |
176 | (when service |
177 | (dolist (elt entry) | |
178 | (let (found) | |
fac7ae53 MA |
179 | (maphash |
180 | (lambda (k v) | |
181 | (dolist (e v) | |
182 | (ignore-errors | |
183 | (when (and (equal bus (car k)) (string-equal service (cadr e))) | |
184 | (setq found t))))) | |
185 | dbus-registered-objects-table) | |
186 | (unless found | |
187 | (dbus-call-method | |
188 | bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus | |
189 | "ReleaseName" service))))) | |
8fb1629f MA |
190 | ;; Return. |
191 | ret)) | |
246a286b | 192 | |
c0a39702 MA |
193 | (defun dbus-unregister-service (bus service) |
194 | "Unregister all objects related to SERVICE from D-Bus BUS. | |
e73f184c | 195 | BUS is either a Lisp symbol, `:system' or `:session', or a string |
5c0b4070 MA |
196 | denoting the bus address. SERVICE must be a known service name. |
197 | ||
198 | The function returns a keyword, indicating the result of the | |
199 | operation. One of the following keywords is returned: | |
200 | ||
201 | `:released': Service has become the primary owner of the name. | |
202 | ||
203 | `:non-existent': Service name does not exist on this bus. | |
204 | ||
205 | `:not-owner': We are neither the primary owner nor waiting in the | |
206 | queue of this service." | |
207 | ||
c0a39702 MA |
208 | (maphash |
209 | (lambda (key value) | |
210 | (dolist (elt value) | |
211 | (ignore-errors | |
212 | (when (and (equal bus (car key)) (string-equal service (cadr elt))) | |
213 | (unless | |
214 | (puthash key (delete elt value) dbus-registered-objects-table) | |
215 | (remhash key dbus-registered-objects-table)))))) | |
216 | dbus-registered-objects-table) | |
0a203b61 MA |
217 | (let ((reply (dbus-call-method |
218 | bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus | |
219 | "ReleaseName" service))) | |
220 | (case reply | |
221 | (1 :released) | |
222 | (2 :non-existent) | |
223 | (3 :not-owner) | |
5c0b4070 | 224 | (t (signal 'dbus-error (list "Could not unregister service" service)))))) |
c0a39702 | 225 | |
98c38bfc MA |
226 | (defun dbus-call-method-non-blocking-handler (&rest args) |
227 | "Handler for reply messages of asynchronous D-Bus message calls. | |
b172ed20 | 228 | It calls the function stored in `dbus-registered-objects-table'. |
98c38bfc MA |
229 | The result will be made available in `dbus-return-values-table'." |
230 | (puthash (list (dbus-event-bus-name last-input-event) | |
231 | (dbus-event-serial-number last-input-event)) | |
232 | (if (= (length args) 1) (car args) args) | |
233 | dbus-return-values-table)) | |
234 | ||
235 | (defun dbus-call-method-non-blocking | |
236 | (bus service path interface method &rest args) | |
237 | "Call METHOD on the D-Bus BUS, but don't block the event queue. | |
238 | This is necessary for communicating to registered D-Bus methods, | |
239 | which are running in the same Emacs process. | |
240 | ||
241 | The arguments are the same as in `dbus-call-method'. | |
242 | ||
243 | usage: (dbus-call-method-non-blocking | |
244 | BUS SERVICE PATH INTERFACE METHOD | |
245 | &optional :timeout TIMEOUT &rest ARGS)" | |
246 | ||
247 | (let ((key | |
248 | (apply | |
249 | 'dbus-call-method-asynchronously | |
250 | bus service path interface method | |
251 | 'dbus-call-method-non-blocking-handler args))) | |
252 | ;; Wait until `dbus-call-method-non-blocking-handler' has put the | |
253 | ;; result into `dbus-return-values-table'. | |
3dec5c36 | 254 | (while (eq (gethash key dbus-return-values-table :ignore) :ignore) |
98c38bfc MA |
255 | (read-event nil nil 0.1)) |
256 | ||
257 | ;; Cleanup `dbus-return-values-table'. Return the result. | |
258 | (prog1 | |
259 | (gethash key dbus-return-values-table nil) | |
260 | (remhash key dbus-return-values-table)))) | |
261 | ||
0e0c4247 | 262 | (defun dbus-name-owner-changed-handler (&rest args) |
e49d337b | 263 | "Reapplies all member registrations to D-Bus. |
ef6ce14c MA |
264 | This handler is applied when a \"NameOwnerChanged\" signal has |
265 | arrived. SERVICE is the object name for which the name owner has | |
266 | been changed. OLD-OWNER is the previous owner of SERVICE, or the | |
267 | empty string if SERVICE was not owned yet. NEW-OWNER is the new | |
537b04b9 | 268 | owner of SERVICE, or the empty string if SERVICE loses any name owner. |
0e0c4247 MA |
269 | |
270 | usage: (dbus-name-owner-changed-handler service old-owner new-owner)" | |
ef6ce14c | 271 | (save-match-data |
0e0c4247 MA |
272 | ;; Check the arguments. We should silently ignore it when they |
273 | ;; are wrong. | |
274 | (if (and (= (length args) 3) | |
275 | (stringp (car args)) | |
276 | (stringp (cadr args)) | |
277 | (stringp (caddr args))) | |
278 | (let ((service (car args)) | |
4d6769e1 | 279 | (old-owner (cadr args))) |
0e0c4247 MA |
280 | ;; Check whether SERVICE is a known name. |
281 | (when (not (string-match "^:" service)) | |
282 | (maphash | |
4f91a816 SM |
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))))) | |
b172ed20 | 297 | (copy-hash-table dbus-registered-objects-table)))) |
0e0c4247 MA |
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)))))) | |
ef6ce14c MA |
305 | |
306 | ;; Register the handler. | |
98c38bfc | 307 | (when nil ;ignore-errors |
246a286b MA |
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)) | |
ef6ce14c | 314 | |
5363d8ea | 315 | \f |
82697a45 MA |
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." | |
d665fff0 MA |
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))))))) | |
82697a45 MA |
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 | |
5363d8ea MA |
367 | ;;; D-Bus events. |
368 | ||
3a993e3d MA |
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 | ||
98c38bfc | 373 | (dbus-event BUS TYPE SERIAL SERVICE PATH INTERFACE MEMBER HANDLER &rest ARGS) |
3a993e3d | 374 | |
e49d337b | 375 | BUS identifies the D-Bus the message is coming from. It is |
e73f184c MA |
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'. | |
3a993e3d MA |
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) | |
5363d8ea | 391 | ;; Bus symbol. |
e73f184c MA |
392 | (or (symbolp (nth 1 event)) |
393 | (stringp (nth 1 event))) | |
98c38bfc MA |
394 | ;; Type. |
395 | (and (natnump (nth 2 event)) | |
396 | (< dbus-message-type-invalid (nth 2 event))) | |
e49d337b | 397 | ;; Serial. |
98c38bfc | 398 | (natnump (nth 3 event)) |
5363d8ea | 399 | ;; Service. |
98c38bfc | 400 | (or (= dbus-message-type-method-return (nth 2 event)) |
ba0b66b0 | 401 | (= dbus-message-type-error (nth 2 event)) |
98c38bfc | 402 | (stringp (nth 4 event))) |
e49d337b | 403 | ;; Object path. |
98c38bfc | 404 | (or (= dbus-message-type-method-return (nth 2 event)) |
ba0b66b0 | 405 | (= dbus-message-type-error (nth 2 event)) |
98c38bfc | 406 | (stringp (nth 5 event))) |
e49d337b | 407 | ;; Interface. |
98c38bfc | 408 | (or (= dbus-message-type-method-return (nth 2 event)) |
ba0b66b0 | 409 | (= dbus-message-type-error (nth 2 event)) |
98c38bfc | 410 | (stringp (nth 6 event))) |
e49d337b | 411 | ;; Member. |
98c38bfc | 412 | (or (= dbus-message-type-method-return (nth 2 event)) |
ba0b66b0 | 413 | (= dbus-message-type-error (nth 2 event)) |
98c38bfc | 414 | (stringp (nth 7 event))) |
ef6ce14c | 415 | ;; Handler. |
98c38bfc | 416 | (functionp (nth 8 event))) |
3a993e3d MA |
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. | |
5363d8ea | 422 | EVENT is a D-Bus event, see `dbus-check-event'. HANDLER, being |
98c38bfc | 423 | part of the event, is called with arguments ARGS. |
35b148ee | 424 | If the HANDLER returns a `dbus-error', it is propagated as return message." |
3a993e3d | 425 | (interactive "e") |
98c38bfc MA |
426 | (condition-case err |
427 | (let (result) | |
ba0b66b0 | 428 | ;; We ignore not well-formed events. |
98c38bfc | 429 | (dbus-check-event event) |
ba0b66b0 MA |
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. | |
98c38bfc MA |
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 | |
3dec5c36 MA |
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))))))) | |
98c38bfc MA |
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)))) | |
ba0b66b0 | 451 | ;; Propagate D-Bus error messages. |
f213fc09 | 452 | (run-hook-with-args 'dbus-event-error-hooks event err) |
ba0b66b0 MA |
453 | (when (or dbus-debug (= dbus-message-type-error (nth 2 event))) |
454 | (signal (car err) (cdr err)))))) | |
3a993e3d MA |
455 | |
456 | (defun dbus-event-bus-name (event) | |
457 | "Return the bus name the event is coming from. | |
e73f184c MA |
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." | |
3a993e3d | 462 | (dbus-check-event event) |
ef6ce14c | 463 | (nth 1 event)) |
3a993e3d | 464 | |
98c38bfc MA |
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 | ||
e49d337b MA |
473 | (defun dbus-event-serial-number (event) |
474 | "Return the serial number of the corresponding D-Bus message. | |
98c38bfc MA |
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." | |
e49d337b | 479 | (dbus-check-event event) |
98c38bfc | 480 | (nth 3 event)) |
e49d337b | 481 | |
3a993e3d | 482 | (defun dbus-event-service-name (event) |
5363d8ea | 483 | "Return the name of the D-Bus object the event is coming from. |
3a993e3d MA |
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) | |
98c38bfc | 488 | (nth 4 event)) |
3a993e3d MA |
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) | |
98c38bfc | 496 | (nth 5 event)) |
3a993e3d MA |
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) | |
98c38bfc | 504 | (nth 6 event)) |
3a993e3d MA |
505 | |
506 | (defun dbus-event-member-name (event) | |
507 | "Return the member name the event is coming from. | |
58179cce | 508 | It is either a signal name or a method name. The result is a |
3a993e3d MA |
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) | |
98c38bfc | 513 | (nth 7 event)) |
5363d8ea MA |
514 | |
515 | \f | |
516 | ;;; D-Bus registered names. | |
3a993e3d | 517 | |
07e52e08 | 518 | (defun dbus-list-activatable-names (&optional bus) |
3a993e3d | 519 | "Return the D-Bus service names which can be activated as list. |
07e52e08 MA |
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." | |
246a286b MA |
523 | (dbus-ignore-errors |
524 | (dbus-call-method | |
07e52e08 | 525 | (or bus :system) dbus-service-dbus |
246a286b | 526 | dbus-path-dbus dbus-interface-dbus "ListActivatableNames"))) |
3a993e3d MA |
527 | |
528 | (defun dbus-list-names (bus) | |
529 | "Return the service names registered at D-Bus BUS. | |
f636d3ca MA |
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." | |
246a286b MA |
534 | (dbus-ignore-errors |
535 | (dbus-call-method | |
536 | bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "ListNames"))) | |
3a993e3d MA |
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) | |
f636d3ca MA |
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." | |
246a286b MA |
550 | (dbus-ignore-errors |
551 | (dbus-call-method | |
552 | bus dbus-service-dbus dbus-path-dbus | |
553 | dbus-interface-dbus "ListQueuedOwners" service))) | |
3a993e3d MA |
554 | |
555 | (defun dbus-get-name-owner (bus service) | |
556 | "Return the name owner of SERVICE registered at D-Bus BUS. | |
f636d3ca | 557 | The result is either a string, or `nil' if there is no name owner." |
246a286b MA |
558 | (dbus-ignore-errors |
559 | (dbus-call-method | |
560 | bus dbus-service-dbus dbus-path-dbus | |
561 | dbus-interface-dbus "GetNameOwner" service))) | |
3a993e3d | 562 | |
93fb0645 MA |
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))" | |
4ba11bcb MA |
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 | |
93fb0645 MA |
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"))) | |
4ba11bcb MA |
583 | (dbus-error nil))) |
584 | ||
f636d3ca MA |
585 | \f |
586 | ;;; D-Bus introspection. | |
3a993e3d | 587 | |
f636d3ca | 588 | (defun dbus-introspect (bus service path) |
35b148ee | 589 | "Return all interfaces and sub-nodes of SERVICE, |
f636d3ca MA |
590 | registered at object path PATH at bus BUS. |
591 | ||
e73f184c MA |
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." | |
736215fd MA |
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. | |
246a286b | 600 | (dbus-ignore-errors |
d4b06783 MA |
601 | (funcall |
602 | (if noninteractive 'dbus-call-method 'dbus-call-method-non-blocking) | |
246a286b | 603 | bus service path dbus-interface-introspectable "Introspect"))) |
3a993e3d | 604 | |
f636d3ca MA |
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, | |
35b148ee JB |
662 | element of the list returned by `dbus-introspect-get-interface-names'. |
663 | The resulting \"interface\" object can contain \"method\", \"signal\", | |
f636d3ca MA |
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. | |
35b148ee JB |
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'." | |
f636d3ca MA |
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 | |
4f91a816 SM |
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 | ""))) | |
f636d3ca MA |
846 | (dbus-introspect-get-argument-names bus service path interface name) |
847 | ""))) | |
3a993e3d | 848 | |
f636d3ca MA |
849 | \f |
850 | ;;; D-Bus properties. | |
3a993e3d | 851 | |
f636d3ca MA |
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." | |
246a286b | 856 | (dbus-ignore-errors |
b172ed20 MA |
857 | ;; "Get" returns a variant, so we must use the `car'. |
858 | (car | |
d4b06783 MA |
859 | (funcall |
860 | (if noninteractive 'dbus-call-method 'dbus-call-method-non-blocking) | |
b172ed20 MA |
861 | bus service path dbus-interface-properties |
862 | "Get" :timeout 500 interface property)))) | |
f636d3ca MA |
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 | |
b172ed20 | 870 | ;; "Set" requires a variant. |
d4b06783 MA |
871 | (funcall |
872 | (if noninteractive 'dbus-call-method 'dbus-call-method-non-blocking) | |
b172ed20 MA |
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))) | |
f636d3ca MA |
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." | |
f636d3ca | 883 | (dbus-ignore-errors |
b172ed20 | 884 | ;; "GetAll" returns "a{sv}". |
f636d3ca | 885 | (let (result) |
b172ed20 | 886 | (dolist (dict |
d4b06783 MA |
887 | (funcall |
888 | (if noninteractive | |
889 | 'dbus-call-method | |
890 | 'dbus-call-method-non-blocking) | |
b172ed20 MA |
891 | bus service path dbus-interface-properties |
892 | "GetAll" :timeout 500 interface) | |
f636d3ca | 893 | result) |
b172ed20 MA |
894 | (add-to-list 'result (cons (car dict) (caadr dict)) 'append))))) |
895 | ||
896 | (defun dbus-register-property | |
6388924a MA |
897 | (bus service path interface property access value |
898 | &optional emits-signal dont-register-service) | |
b172ed20 MA |
899 | "Register property PROPERTY on the D-Bus BUS. |
900 | ||
e73f184c MA |
901 | BUS is either a Lisp symbol, `:system' or `:session', or a string |
902 | denoting the bus address. | |
b172ed20 MA |
903 | |
904 | SERVICE is the D-Bus service name of the D-Bus. It must be a | |
6388924a MA |
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 | |
b172ed20 MA |
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 | |
b1ce08da MA |
923 | \"Set\" methods of this interface. When EMITS-SIGNAL is non-nil, |
924 | the signal \"PropertiesChanged\" is sent when the property is | |
6388924a MA |
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." | |
b172ed20 MA |
933 | (unless (member access '(:read :readwrite)) |
934 | (signal 'dbus-error (list "Access type invalid" access))) | |
935 | ||
936 | ;; Register SERVICE. | |
6388924a MA |
937 | (unless (or dont-register-service |
938 | (member service (dbus-list-names bus))) | |
b172ed20 MA |
939 | (dbus-call-method |
940 | bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus | |
941 | "RequestName" service 0)) | |
942 | ||
0a203b61 | 943 | ;; Add handlers for the three property-related methods. |
b172ed20 | 944 | (dbus-register-method |
0a203b61 | 945 | bus service path dbus-interface-properties "Get" |
1a27c64e | 946 | 'dbus-property-handler 'dont-register) |
b172ed20 | 947 | (dbus-register-method |
1a27c64e MA |
948 | bus service path dbus-interface-properties "GetAll" |
949 | 'dbus-property-handler 'dont-register) | |
b172ed20 | 950 | (dbus-register-method |
1a27c64e MA |
951 | bus service path dbus-interface-properties "Set" |
952 | 'dbus-property-handler 'dont-register) | |
0a203b61 MA |
953 | |
954 | ;; Register the name SERVICE with BUS. | |
955 | (unless dont-register-service | |
956 | (dbus-register-service bus service)) | |
b172ed20 | 957 | |
b1ce08da MA |
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 | ||
b172ed20 MA |
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)) | |
b1ce08da MA |
968 | (val |
969 | (list | |
970 | (list | |
971 | nil service path | |
972 | (cons | |
973 | (if emits-signal (list access :emits-signal) (list access)) | |
974 | value))))) | |
b172ed20 MA |
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) | |
35b148ee | 981 | "Default handler for the \"org.freedesktop.DBus.Properties\" interface. |
c0a39702 | 982 | It will be registered for all objects created by `dbus-register-object'." |
b172ed20 | 983 | (let ((bus (dbus-event-bus-name last-input-event)) |
b1ce08da | 984 | (service (dbus-event-service-name last-input-event)) |
b172ed20 MA |
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") | |
b1ce08da MA |
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)))))))) | |
b172ed20 MA |
996 | |
997 | ;; "Set" expects a variant. | |
998 | ((string-equal method "Set") | |
b1ce08da MA |
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) | |
b172ed20 MA |
1010 | (signal 'dbus-error |
1011 | (list "Property not registered at path" property path))) | |
b1ce08da | 1012 | (unless (member :readwrite (car object)) |
b172ed20 MA |
1013 | (signal 'dbus-error |
1014 | (list "Property not writable at path" property path))) | |
1015 | (puthash (list bus interface property) | |
b1ce08da MA |
1016 | (list (append (butlast (car entry)) |
1017 | (list (cons (car object) value)))) | |
b172ed20 | 1018 | dbus-registered-objects-table) |
b1ce08da MA |
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. | |
b172ed20 MA |
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))) | |
31bb373f | 1035 | (not (functionp (car (last (car val)))))) |
b172ed20 MA |
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) | |
052e28ac MA |
1042 | ;; Return the result, or an empty array. |
1043 | (list :array (or result '(:signature "{sv}")))))))) | |
b172ed20 MA |
1044 | |
1045 | \f | |
720c7cd6 MA |
1046 | ;; Initialize :system and :session buses. This adds their file |
1047 | ;; descriptors to input_wait_mask, in order to detect incoming | |
1048 | ;; messages immediately. | |
9e846523 MA |
1049 | (when (featurep 'dbusbind) |
1050 | (dbus-ignore-errors | |
1051 | (dbus-init-bus :system) | |
1052 | (dbus-init-bus :session))) | |
720c7cd6 | 1053 | |
3a993e3d MA |
1054 | (provide 'dbus) |
1055 | ||
1056 | ;;; dbus.el ends here |