Commit | Line | Data |
---|---|---|
3a993e3d MA |
1 | ;;; dbus.el --- Elisp bindings for D-Bus. |
2 | ||
ba318903 | 3 | ;; Copyright (C) 2007-2014 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 | ||
dcbf5805 MA |
31 | ;; D-Bus support in the Emacs core can be disabled with configuration |
32 | ;; option "--without-dbus". | |
33 | ||
3a993e3d MA |
34 | ;;; Code: |
35 | ||
dcbf5805 MA |
36 | ;; Declare used subroutines and variables. |
37 | (declare-function dbus-message-internal "dbusbind.c") | |
48198420 | 38 | (declare-function dbus-init-bus-1 "dbusbind.c") |
dcbf5805 MA |
39 | (defvar dbus-message-type-invalid) |
40 | (defvar dbus-message-type-method-call) | |
41 | (defvar dbus-message-type-method-return) | |
42 | (defvar dbus-message-type-error) | |
43 | (defvar dbus-message-type-signal) | |
6981d00a | 44 | (defvar dbus-debug) |
b172ed20 | 45 | (defvar dbus-registered-objects-table) |
6981d00a MA |
46 | |
47 | ;; Pacify byte compiler. | |
f58e0fd5 | 48 | (eval-when-compile (require 'cl-lib)) |
7bb7efbd | 49 | |
3a993e3d MA |
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 | ||
dcbf5805 MA |
58 | ;; Default D-Bus interfaces. |
59 | ||
3a993e3d | 60 | (defconst dbus-interface-dbus "org.freedesktop.DBus" |
dcbf5805 | 61 | "The interface exported by the service `dbus-service-dbus'.") |
3a993e3d | 62 | |
4ba11bcb | 63 | (defconst dbus-interface-peer (concat dbus-interface-dbus ".Peer") |
dcbf5805 MA |
64 | "The interface for peer objects. |
65 | See URL `http://dbus.freedesktop.org/doc/dbus-specification.html#standard-interfaces-peer'.") | |
66 | ||
67 | ;; <interface name="org.freedesktop.DBus.Peer"> | |
68 | ;; <method name="Ping"> | |
69 | ;; </method> | |
70 | ;; <method name="GetMachineId"> | |
71 | ;; <arg name="machine_uuid" type="s" direction="out"/> | |
72 | ;; </method> | |
73 | ;; </interface> | |
4ba11bcb MA |
74 | |
75 | (defconst dbus-interface-introspectable | |
76 | (concat dbus-interface-dbus ".Introspectable") | |
dcbf5805 MA |
77 | "The interface supported by introspectable objects. |
78 | See URL `http://dbus.freedesktop.org/doc/dbus-specification.html#standard-interfaces-introspectable'.") | |
3a993e3d | 79 | |
dcbf5805 MA |
80 | ;; <interface name="org.freedesktop.DBus.Introspectable"> |
81 | ;; <method name="Introspect"> | |
82 | ;; <arg name="data" type="s" direction="out"/> | |
83 | ;; </method> | |
84 | ;; </interface> | |
f636d3ca | 85 | |
dcbf5805 MA |
86 | (defconst dbus-interface-properties (concat dbus-interface-dbus ".Properties") |
87 | "The interface for property objects. | |
88 | See URL `http://dbus.freedesktop.org/doc/dbus-specification.html#standard-interfaces-properties'.") | |
89 | ||
90 | ;; <interface name="org.freedesktop.DBus.Properties"> | |
91 | ;; <method name="Get"> | |
92 | ;; <arg name="interface" type="s" direction="in"/> | |
93 | ;; <arg name="propname" type="s" direction="in"/> | |
94 | ;; <arg name="value" type="v" direction="out"/> | |
95 | ;; </method> | |
96 | ;; <method name="Set"> | |
97 | ;; <arg name="interface" type="s" direction="in"/> | |
98 | ;; <arg name="propname" type="s" direction="in"/> | |
99 | ;; <arg name="value" type="v" direction="in"/> | |
100 | ;; </method> | |
101 | ;; <method name="GetAll"> | |
102 | ;; <arg name="interface" type="s" direction="in"/> | |
103 | ;; <arg name="props" type="a{sv}" direction="out"/> | |
104 | ;; </method> | |
105 | ;; <signal name="PropertiesChanged"> | |
106 | ;; <arg name="interface" type="s"/> | |
107 | ;; <arg name="changed_properties" type="a{sv}"/> | |
108 | ;; <arg name="invalidated_properties" type="as"/> | |
109 | ;; </signal> | |
110 | ;; </interface> | |
111 | ||
112 | (defconst dbus-interface-objectmanager | |
113 | (concat dbus-interface-dbus ".ObjectManager") | |
114 | "The object manager interface. | |
115 | See URL `http://dbus.freedesktop.org/doc/dbus-specification.html#standard-interfaces-objectmanager'.") | |
116 | ||
117 | ;; <interface name="org.freedesktop.DBus.ObjectManager"> | |
118 | ;; <method name="GetManagedObjects"> | |
119 | ;; <arg name="object_paths_interfaces_and_properties" | |
120 | ;; type="a{oa{sa{sv}}}" direction="out"/> | |
121 | ;; </method> | |
122 | ;; <signal name="InterfacesAdded"> | |
123 | ;; <arg name="object_path" type="o"/> | |
124 | ;; <arg name="interfaces_and_properties" type="a{sa{sv}}"/> | |
125 | ;; </signal> | |
126 | ;; <signal name="InterfacesRemoved"> | |
127 | ;; <arg name="object_path" type="o"/> | |
128 | ;; <arg name="interfaces" type="as"/> | |
129 | ;; </signal> | |
130 | ;; </interface> | |
131 | ||
132 | ;; Emacs defaults. | |
65b7cb2c MA |
133 | (defconst dbus-service-emacs "org.gnu.Emacs" |
134 | "The well known service name of Emacs.") | |
135 | ||
136 | (defconst dbus-path-emacs "/org/gnu/Emacs" | |
dcbf5805 MA |
137 | "The object path namespace used by Emacs. |
138 | All object paths provided by the service `dbus-service-emacs' | |
139 | shall be subdirectories of this path.") | |
65b7cb2c | 140 | |
dcbf5805 MA |
141 | (defconst dbus-interface-emacs "org.gnu.Emacs" |
142 | "The interface namespace used by Emacs.") | |
98c38bfc | 143 | |
dcbf5805 | 144 | ;; D-Bus constants. |
98c38bfc | 145 | |
246a286b MA |
146 | (defmacro dbus-ignore-errors (&rest body) |
147 | "Execute BODY; signal D-Bus error when `dbus-debug' is non-nil. | |
148 | Otherwise, return result of last form in BODY, or all other errors." | |
f291fe60 | 149 | (declare (indent 0) (debug t)) |
246a286b MA |
150 | `(condition-case err |
151 | (progn ,@body) | |
152 | (dbus-error (when dbus-debug (signal (car err) (cdr err)))))) | |
246a286b MA |
153 | (font-lock-add-keywords 'emacs-lisp-mode '("\\<dbus-ignore-errors\\>")) |
154 | ||
d1069532 SM |
155 | (define-obsolete-variable-alias 'dbus-event-error-hooks |
156 | 'dbus-event-error-functions "24.3") | |
48198420 | 157 | (defvar dbus-event-error-functions '(dbus-notice-synchronous-call-errors) |
e12c189f | 158 | "Functions to be called when a D-Bus error happens in the event handler. |
f213fc09 | 159 | Every function must accept two arguments, the event and the error variable |
333f9019 | 160 | caught in `condition-case' by `dbus-error'.") |
e12c189f | 161 | |
5363d8ea | 162 | \f |
dcbf5805 | 163 | ;;; Basic D-Bus message functions. |
5363d8ea | 164 | |
98c38bfc MA |
165 | (defvar dbus-return-values-table (make-hash-table :test 'equal) |
166 | "Hash table for temporary storing arguments of reply messages. | |
dcbf5805 MA |
167 | A key in this hash table is a list (:serial BUS SERIAL), like in |
168 | `dbus-registered-objects-table'. BUS is either a Lisp symbol, | |
169 | `:system' or `:session', or a string denoting the bus address. | |
170 | SERIAL is the serial number of the reply message.") | |
171 | ||
172 | (defun dbus-call-method-handler (&rest args) | |
173 | "Handler for reply messages of asynchronous D-Bus message calls. | |
174 | It calls the function stored in `dbus-registered-objects-table'. | |
175 | The result will be made available in `dbus-return-values-table'." | |
48198420 DC |
176 | (let* ((key (list :serial |
177 | (dbus-event-bus-name last-input-event) | |
178 | (dbus-event-serial-number last-input-event))) | |
179 | (result (gethash key dbus-return-values-table))) | |
180 | (when (consp result) | |
181 | (setcar result :complete) | |
182 | (setcdr result (if (= (length args) 1) (car args) args))))) | |
183 | ||
184 | (defun dbus-notice-synchronous-call-errors (ev er) | |
185 | "Detect errors resulting from pending synchronous calls." | |
186 | (let* ((key (list :serial | |
187 | (dbus-event-bus-name ev) | |
188 | (dbus-event-serial-number ev))) | |
189 | (result (gethash key dbus-return-values-table))) | |
190 | (when (consp result) | |
191 | (setcar result :error) | |
192 | (setcdr result er)))) | |
dcbf5805 MA |
193 | |
194 | (defun dbus-call-method (bus service path interface method &rest args) | |
195 | "Call METHOD on the D-Bus BUS. | |
196 | ||
197 | BUS is either a Lisp symbol, `:system' or `:session', or a string | |
198 | denoting the bus address. | |
199 | ||
200 | SERVICE is the D-Bus service name to be used. PATH is the D-Bus | |
201 | object path SERVICE is registered at. INTERFACE is an interface | |
202 | offered by SERVICE. It must provide METHOD. | |
203 | ||
204 | If the parameter `:timeout' is given, the following integer TIMEOUT | |
205 | specifies the maximum number of milliseconds the method call must | |
206 | return. The default value is 25,000. If the method call doesn't | |
207 | return in time, a D-Bus error is raised. | |
208 | ||
209 | All other arguments ARGS are passed to METHOD as arguments. They are | |
210 | converted into D-Bus types via the following rules: | |
211 | ||
212 | t and nil => DBUS_TYPE_BOOLEAN | |
213 | number => DBUS_TYPE_UINT32 | |
214 | integer => DBUS_TYPE_INT32 | |
215 | float => DBUS_TYPE_DOUBLE | |
216 | string => DBUS_TYPE_STRING | |
217 | list => DBUS_TYPE_ARRAY | |
218 | ||
219 | All arguments can be preceded by a type symbol. For details about | |
220 | type symbols, see Info node `(dbus)Type Conversion'. | |
221 | ||
222 | `dbus-call-method' returns the resulting values of METHOD as a list of | |
223 | Lisp objects. The type conversion happens the other direction as for | |
224 | input arguments. It follows the mapping rules: | |
225 | ||
226 | DBUS_TYPE_BOOLEAN => t or nil | |
227 | DBUS_TYPE_BYTE => number | |
228 | DBUS_TYPE_UINT16 => number | |
229 | DBUS_TYPE_INT16 => integer | |
230 | DBUS_TYPE_UINT32 => number or float | |
231 | DBUS_TYPE_UNIX_FD => number or float | |
232 | DBUS_TYPE_INT32 => integer or float | |
233 | DBUS_TYPE_UINT64 => number or float | |
234 | DBUS_TYPE_INT64 => integer or float | |
235 | DBUS_TYPE_DOUBLE => float | |
236 | DBUS_TYPE_STRING => string | |
237 | DBUS_TYPE_OBJECT_PATH => string | |
238 | DBUS_TYPE_SIGNATURE => string | |
239 | DBUS_TYPE_ARRAY => list | |
240 | DBUS_TYPE_VARIANT => list | |
241 | DBUS_TYPE_STRUCT => list | |
242 | DBUS_TYPE_DICT_ENTRY => list | |
243 | ||
244 | Example: | |
245 | ||
246 | \(dbus-call-method | |
247 | :session \"org.gnome.seahorse\" \"/org/gnome/seahorse/keys/openpgp\" | |
248 | \"org.gnome.seahorse.Keys\" \"GetKeyField\" | |
249 | \"openpgp:657984B8C7A966DD\" \"simple-name\") | |
250 | ||
251 | => (t (\"Philip R. Zimmermann\")) | |
252 | ||
253 | If the result of the METHOD call is just one value, the converted Lisp | |
254 | object is returned instead of a list containing this single Lisp object. | |
255 | ||
256 | \(dbus-call-method | |
257 | :system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/devices/computer\" | |
258 | \"org.freedesktop.Hal.Device\" \"GetPropertyString\" | |
259 | \"system.kernel.machine\") | |
260 | ||
261 | => \"i686\"" | |
262 | ||
263 | (or (memq bus '(:system :session)) (stringp bus) | |
264 | (signal 'wrong-type-argument (list 'keywordp bus))) | |
265 | (or (stringp service) | |
266 | (signal 'wrong-type-argument (list 'stringp service))) | |
267 | (or (stringp path) | |
268 | (signal 'wrong-type-argument (list 'stringp path))) | |
269 | (or (stringp interface) | |
270 | (signal 'wrong-type-argument (list 'stringp interface))) | |
271 | (or (stringp method) | |
272 | (signal 'wrong-type-argument (list 'stringp method))) | |
273 | ||
274 | (let ((timeout (plist-get args :timeout)) | |
26ea164c | 275 | (check-interval 0.001) |
dcbf5805 MA |
276 | (key |
277 | (apply | |
278 | 'dbus-message-internal dbus-message-type-method-call | |
48198420 DC |
279 | bus service path interface method 'dbus-call-method-handler args)) |
280 | (result (cons :pending nil))) | |
205a7391 | 281 | |
dcbf5805 MA |
282 | ;; Wait until `dbus-call-method-handler' has put the result into |
283 | ;; `dbus-return-values-table'. If no timeout is given, use the | |
205a7391 | 284 | ;; default 25". Events which are not from D-Bus must be restored. |
ec518f1a MA |
285 | ;; `read-event' performs a redisplay. This must be suppressed; it |
286 | ;; hurts when reading D-Bus events asynchronously. | |
26ea164c DC |
287 | |
288 | ;; Work around bug#16775 by busy-waiting with gradual backoff for | |
16f4c9f1 | 289 | ;; dbus calls to complete. A better approach would involve either |
26ea164c DC |
290 | ;; adding arbitrary wait condition support to read-event or |
291 | ;; restructuring dbus as a kind of process object. Poll at most | |
292 | ;; about once per second for completion. | |
293 | ||
48198420 DC |
294 | (puthash key result dbus-return-values-table) |
295 | (unwind-protect | |
296 | (progn | |
297 | (with-timeout ((if timeout (/ timeout 1000.0) 25) | |
298 | (signal 'dbus-error (list "call timed out"))) | |
299 | (while (eq (car result) :pending) | |
300 | (let ((event (let ((inhibit-redisplay t) unread-command-events) | |
301 | (read-event nil nil check-interval)))) | |
302 | (when event | |
303 | (setf unread-command-events | |
304 | (nconc unread-command-events | |
305 | (cons event nil)))) | |
306 | (when (< check-interval 1) | |
307 | (setf check-interval (* check-interval 1.05)))))) | |
308 | (when (eq (car result) :error) | |
309 | (signal (cadr result) (cddr result))) | |
310 | (cdr result)) | |
dcbf5805 MA |
311 | (remhash key dbus-return-values-table)))) |
312 | ||
313 | ;; `dbus-call-method' works non-blocking now. | |
314 | (defalias 'dbus-call-method-non-blocking 'dbus-call-method) | |
2a1e2476 | 315 | (make-obsolete 'dbus-call-method-non-blocking 'dbus-call-method "24.3") |
dcbf5805 MA |
316 | |
317 | (defun dbus-call-method-asynchronously | |
318 | (bus service path interface method handler &rest args) | |
319 | "Call METHOD on the D-Bus BUS asynchronously. | |
320 | ||
321 | BUS is either a Lisp symbol, `:system' or `:session', or a string | |
322 | denoting the bus address. | |
323 | ||
324 | SERVICE is the D-Bus service name to be used. PATH is the D-Bus | |
325 | object path SERVICE is registered at. INTERFACE is an interface | |
326 | offered by SERVICE. It must provide METHOD. | |
327 | ||
328 | HANDLER is a Lisp function, which is called when the corresponding | |
329 | return message has arrived. If HANDLER is nil, no return message | |
330 | will be expected. | |
331 | ||
332 | If the parameter `:timeout' is given, the following integer TIMEOUT | |
333 | specifies the maximum number of milliseconds the method call must | |
334 | return. The default value is 25,000. If the method call doesn't | |
335 | return in time, a D-Bus error is raised. | |
336 | ||
337 | All other arguments ARGS are passed to METHOD as arguments. They are | |
338 | converted into D-Bus types via the following rules: | |
339 | ||
340 | t and nil => DBUS_TYPE_BOOLEAN | |
341 | number => DBUS_TYPE_UINT32 | |
342 | integer => DBUS_TYPE_INT32 | |
343 | float => DBUS_TYPE_DOUBLE | |
344 | string => DBUS_TYPE_STRING | |
345 | list => DBUS_TYPE_ARRAY | |
346 | ||
347 | All arguments can be preceded by a type symbol. For details about | |
348 | type symbols, see Info node `(dbus)Type Conversion'. | |
349 | ||
350 | If HANDLER is a Lisp function, the function returns a key into the | |
351 | hash table `dbus-registered-objects-table'. The corresponding entry | |
352 | in the hash table is removed, when the return message has been arrived, | |
353 | and HANDLER is called. | |
354 | ||
355 | Example: | |
356 | ||
357 | \(dbus-call-method-asynchronously | |
358 | :system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/devices/computer\" | |
359 | \"org.freedesktop.Hal.Device\" \"GetPropertyString\" 'message | |
360 | \"system.kernel.machine\") | |
361 | ||
362 | => \(:serial :system 2) | |
363 | ||
364 | -| i686" | |
365 | ||
366 | (or (memq bus '(:system :session)) (stringp bus) | |
367 | (signal 'wrong-type-argument (list 'keywordp bus))) | |
368 | (or (stringp service) | |
369 | (signal 'wrong-type-argument (list 'stringp service))) | |
370 | (or (stringp path) | |
371 | (signal 'wrong-type-argument (list 'stringp path))) | |
372 | (or (stringp interface) | |
373 | (signal 'wrong-type-argument (list 'stringp interface))) | |
374 | (or (stringp method) | |
375 | (signal 'wrong-type-argument (list 'stringp method))) | |
376 | (or (null handler) (functionp handler) | |
377 | (signal 'wrong-type-argument (list 'functionp handler))) | |
378 | ||
379 | (apply 'dbus-message-internal dbus-message-type-method-call | |
380 | bus service path interface method handler args)) | |
381 | ||
382 | (defun dbus-send-signal (bus service path interface signal &rest args) | |
383 | "Send signal SIGNAL on the D-Bus BUS. | |
384 | ||
385 | BUS is either a Lisp symbol, `:system' or `:session', or a string | |
386 | denoting the bus address. The signal is sent from the D-Bus object | |
387 | Emacs is registered at BUS. | |
388 | ||
389 | SERVICE is the D-Bus name SIGNAL is sent to. It can be either a known | |
390 | name or a unique name. If SERVICE is nil, the signal is sent as | |
391 | broadcast message. PATH is the D-Bus object path SIGNAL is sent from. | |
392 | INTERFACE is an interface available at PATH. It must provide signal | |
393 | SIGNAL. | |
394 | ||
395 | All other arguments ARGS are passed to SIGNAL as arguments. They are | |
396 | converted into D-Bus types via the following rules: | |
397 | ||
398 | t and nil => DBUS_TYPE_BOOLEAN | |
399 | number => DBUS_TYPE_UINT32 | |
400 | integer => DBUS_TYPE_INT32 | |
401 | float => DBUS_TYPE_DOUBLE | |
402 | string => DBUS_TYPE_STRING | |
403 | list => DBUS_TYPE_ARRAY | |
404 | ||
405 | All arguments can be preceded by a type symbol. For details about | |
406 | type symbols, see Info node `(dbus)Type Conversion'. | |
407 | ||
408 | Example: | |
409 | ||
410 | \(dbus-send-signal | |
411 | :session nil \"/org/gnu/Emacs\" \"org.gnu.Emacs.FileManager\" | |
412 | \"FileModified\" \"/home/albinus/.emacs\")" | |
413 | ||
414 | (or (memq bus '(:system :session)) (stringp bus) | |
415 | (signal 'wrong-type-argument (list 'keywordp bus))) | |
416 | (or (null service) (stringp service) | |
417 | (signal 'wrong-type-argument (list 'stringp service))) | |
418 | (or (stringp path) | |
419 | (signal 'wrong-type-argument (list 'stringp path))) | |
420 | (or (stringp interface) | |
421 | (signal 'wrong-type-argument (list 'stringp interface))) | |
422 | (or (stringp signal) | |
423 | (signal 'wrong-type-argument (list 'stringp signal))) | |
424 | ||
425 | (apply 'dbus-message-internal dbus-message-type-signal | |
426 | bus service path interface signal args)) | |
427 | ||
428 | (defun dbus-method-return-internal (bus service serial &rest args) | |
429 | "Return for message SERIAL on the D-Bus BUS. | |
430 | This is an internal function, it shall not be used outside dbus.el." | |
431 | ||
432 | (or (memq bus '(:system :session)) (stringp bus) | |
433 | (signal 'wrong-type-argument (list 'keywordp bus))) | |
434 | (or (stringp service) | |
435 | (signal 'wrong-type-argument (list 'stringp service))) | |
436 | (or (natnump serial) | |
437 | (signal 'wrong-type-argument (list 'natnump serial))) | |
438 | ||
439 | (apply 'dbus-message-internal dbus-message-type-method-return | |
440 | bus service serial args)) | |
441 | ||
442 | (defun dbus-method-error-internal (bus service serial &rest args) | |
443 | "Return error message for message SERIAL on the D-Bus BUS. | |
444 | This is an internal function, it shall not be used outside dbus.el." | |
445 | ||
446 | (or (memq bus '(:system :session)) (stringp bus) | |
447 | (signal 'wrong-type-argument (list 'keywordp bus))) | |
448 | (or (stringp service) | |
449 | (signal 'wrong-type-argument (list 'stringp service))) | |
450 | (or (natnump serial) | |
451 | (signal 'wrong-type-argument (list 'natnump serial))) | |
452 | ||
453 | (apply 'dbus-message-internal dbus-message-type-error | |
454 | bus service serial args)) | |
455 | ||
456 | \f | |
457 | ;;; Hash table of registered functions. | |
98c38bfc | 458 | |
ef6ce14c | 459 | (defun dbus-list-hash-table () |
e49d337b | 460 | "Returns all registered member registrations to D-Bus. |
ef6ce14c | 461 | The return value is a list, with elements of kind (KEY . VALUE). |
b172ed20 | 462 | See `dbus-registered-objects-table' for a description of the |
ef6ce14c MA |
463 | hash table." |
464 | (let (result) | |
465 | (maphash | |
4f91a816 | 466 | (lambda (key value) (add-to-list 'result (cons key value) 'append)) |
b172ed20 | 467 | dbus-registered-objects-table) |
ef6ce14c MA |
468 | result)) |
469 | ||
dcbf5805 MA |
470 | (defun dbus-setenv (bus variable value) |
471 | "Set the value of the BUS environment variable named VARIABLE to VALUE. | |
b172ed20 | 472 | |
dcbf5805 MA |
473 | BUS is either a Lisp symbol, `:system' or `:session', or a string |
474 | denoting the bus address. Both VARIABLE and VALUE should be strings. | |
246a286b | 475 | |
dcbf5805 MA |
476 | Normally, services inherit the environment of the BUS daemon. This |
477 | function adds to or modifies that environment when activating services. | |
b172ed20 | 478 | |
dcbf5805 MA |
479 | Some bus instances, such as `:system', may disable setting the environment." |
480 | (dbus-call-method | |
481 | bus dbus-service-dbus dbus-path-dbus | |
482 | dbus-interface-dbus "UpdateActivationEnvironment" | |
483 | `(:array (:dict-entry ,variable ,value)))) | |
484 | ||
485 | (defun dbus-register-service (bus service &rest flags) | |
486 | "Register known name SERVICE on the D-Bus BUS. | |
487 | ||
488 | BUS is either a Lisp symbol, `:system' or `:session', or a string | |
489 | denoting the bus address. | |
490 | ||
491 | SERVICE is the D-Bus service name that should be registered. It must | |
492 | be a known name. | |
493 | ||
494 | FLAGS are keywords, which control how the service name is registered. | |
495 | The following keywords are recognized: | |
496 | ||
497 | `:allow-replacement': Allow another service to become the primary | |
498 | owner if requested. | |
499 | ||
500 | `:replace-existing': Request to replace the current primary owner. | |
501 | ||
502 | `:do-not-queue': If we can not become the primary owner do not place | |
503 | us in the queue. | |
504 | ||
505 | The function returns a keyword, indicating the result of the | |
506 | operation. One of the following keywords is returned: | |
507 | ||
508 | `:primary-owner': Service has become the primary owner of the | |
509 | requested name. | |
510 | ||
511 | `:in-queue': Service could not become the primary owner and has been | |
512 | placed in the queue. | |
513 | ||
514 | `:exists': Service is already in the queue. | |
515 | ||
516 | `:already-owner': Service is already the primary owner." | |
517 | ||
518 | ;; Add ObjectManager handler. | |
519 | (dbus-register-method | |
520 | bus service nil dbus-interface-objectmanager "GetManagedObjects" | |
521 | 'dbus-managed-objects-handler 'dont-register) | |
522 | ||
523 | (let ((arg 0) | |
524 | reply) | |
525 | (dolist (flag flags) | |
526 | (setq arg | |
527 | (+ arg | |
f58e0fd5 | 528 | (pcase flag |
dcbf5805 MA |
529 | (:allow-replacement 1) |
530 | (:replace-existing 2) | |
531 | (:do-not-queue 4) | |
f58e0fd5 | 532 | (_ (signal 'wrong-type-argument (list flag))))))) |
dcbf5805 MA |
533 | (setq reply (dbus-call-method |
534 | bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus | |
535 | "RequestName" service arg)) | |
f58e0fd5 | 536 | (pcase reply |
dcbf5805 MA |
537 | (1 :primary-owner) |
538 | (2 :in-queue) | |
539 | (3 :exists) | |
540 | (4 :already-owner) | |
f58e0fd5 | 541 | (_ (signal 'dbus-error (list "Could not register service" service)))))) |
246a286b | 542 | |
c0a39702 MA |
543 | (defun dbus-unregister-service (bus service) |
544 | "Unregister all objects related to SERVICE from D-Bus BUS. | |
e73f184c | 545 | BUS is either a Lisp symbol, `:system' or `:session', or a string |
5c0b4070 MA |
546 | denoting the bus address. SERVICE must be a known service name. |
547 | ||
548 | The function returns a keyword, indicating the result of the | |
549 | operation. One of the following keywords is returned: | |
550 | ||
b85eff45 | 551 | `:released': We successfully released the service. |
5c0b4070 MA |
552 | |
553 | `:non-existent': Service name does not exist on this bus. | |
554 | ||
555 | `:not-owner': We are neither the primary owner nor waiting in the | |
556 | queue of this service." | |
557 | ||
c0a39702 MA |
558 | (maphash |
559 | (lambda (key value) | |
b85eff45 MA |
560 | (unless (equal :serial (car key)) |
561 | (dolist (elt value) | |
562 | (ignore-errors | |
563 | (when (and (equal bus (cadr key)) (string-equal service (cadr elt))) | |
564 | (unless | |
565 | (puthash key (delete elt value) dbus-registered-objects-table) | |
566 | (remhash key dbus-registered-objects-table))))))) | |
c0a39702 | 567 | dbus-registered-objects-table) |
0a203b61 MA |
568 | (let ((reply (dbus-call-method |
569 | bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus | |
570 | "ReleaseName" service))) | |
f58e0fd5 | 571 | (pcase reply |
0a203b61 MA |
572 | (1 :released) |
573 | (2 :non-existent) | |
574 | (3 :not-owner) | |
f58e0fd5 | 575 | (_ (signal 'dbus-error (list "Could not unregister service" service)))))) |
c0a39702 | 576 | |
dcbf5805 MA |
577 | (defun dbus-register-signal |
578 | (bus service path interface signal handler &rest args) | |
579 | "Register for a signal on the D-Bus BUS. | |
98c38bfc | 580 | |
dcbf5805 MA |
581 | BUS is either a Lisp symbol, `:system' or `:session', or a string |
582 | denoting the bus address. | |
98c38bfc | 583 | |
dcbf5805 MA |
584 | SERVICE is the D-Bus service name used by the sending D-Bus object. |
585 | It can be either a known name or the unique name of the D-Bus object | |
586 | sending the signal. | |
587 | ||
588 | PATH is the D-Bus object path SERVICE is registered. INTERFACE | |
589 | is an interface offered by SERVICE. It must provide SIGNAL. | |
590 | HANDLER is a Lisp function to be called when the signal is | |
591 | received. It must accept as arguments the values SIGNAL is | |
592 | sending. | |
593 | ||
594 | SERVICE, PATH, INTERFACE and SIGNAL can be nil. This is | |
595 | interpreted as a wildcard for the respective argument. | |
596 | ||
597 | The remaining arguments ARGS can be keywords or keyword string pairs. | |
598 | The meaning is as follows: | |
599 | ||
600 | `:argN' STRING: | |
601 | `:pathN' STRING: This stands for the Nth argument of the | |
602 | signal. `:pathN' arguments can be used for object path wildcard | |
0ba2624f | 603 | matches as specified by D-Bus, while an `:argN' argument |
dcbf5805 MA |
604 | requires an exact match. |
605 | ||
606 | `:arg-namespace' STRING: Register for the signals, which first | |
607 | argument defines the service or interface namespace STRING. | |
608 | ||
609 | `:path-namespace' STRING: Register for the object path namespace | |
610 | STRING. All signals sent from an object path, which has STRING as | |
611 | the preceding string, are matched. This requires PATH to be nil. | |
612 | ||
613 | `:eavesdrop': Register for unicast signals which are not directed | |
614 | to the D-Bus object Emacs is registered at D-Bus BUS, if the | |
615 | security policy of BUS allows this. | |
616 | ||
617 | Example: | |
618 | ||
619 | \(defun my-signal-handler (device) | |
620 | (message \"Device %s added\" device)) | |
621 | ||
622 | \(dbus-register-signal | |
623 | :system \"org.freedesktop.Hal\" \"/org/freedesktop/Hal/Manager\" | |
624 | \"org.freedesktop.Hal.Manager\" \"DeviceAdded\" 'my-signal-handler) | |
625 | ||
626 | => \(\(:signal :system \"org.freedesktop.Hal.Manager\" \"DeviceAdded\") | |
627 | \(\"org.freedesktop.Hal\" \"/org/freedesktop/Hal/Manager\" my-signal-handler)) | |
628 | ||
629 | `dbus-register-signal' returns an object, which can be used in | |
630 | `dbus-unregister-object' for removing the registration." | |
631 | ||
632 | (let ((counter 0) | |
633 | (rule "type='signal'") | |
634 | uname key key1 value) | |
635 | ||
636 | ;; Retrieve unique name of service. If service is a known name, | |
637 | ;; we will register for the corresponding unique name, if any. | |
638 | ;; Signals are sent always with the unique name as sender. Note: | |
639 | ;; the unique name of `dbus-service-dbus' is that string itself. | |
640 | (if (and (stringp service) | |
641 | (not (zerop (length service))) | |
642 | (not (string-equal service dbus-service-dbus)) | |
643 | (not (string-match "^:" service))) | |
644 | (setq uname (dbus-get-name-owner bus service)) | |
645 | (setq uname service)) | |
646 | ||
647 | (setq rule (concat rule | |
648 | (when uname (format ",sender='%s'" uname)) | |
649 | (when interface (format ",interface='%s'" interface)) | |
650 | (when signal (format ",member='%s'" signal)) | |
651 | (when path (format ",path='%s'" path)))) | |
652 | ||
653 | ;; Add arguments to the rule. | |
654 | (if (or (stringp (car args)) (null (car args))) | |
655 | ;; As backward compatibility option, we allow just strings. | |
656 | (dolist (arg args) | |
657 | (if (stringp arg) | |
658 | (setq rule (concat rule (format ",arg%d='%s'" counter arg))) | |
659 | (if arg (signal 'wrong-type-argument (list "Wrong argument" arg)))) | |
660 | (setq counter (1+ counter))) | |
661 | ||
662 | ;; Parse keywords. | |
663 | (while args | |
664 | (setq | |
665 | key (car args) | |
666 | rule (concat | |
667 | rule | |
668 | (cond | |
669 | ;; `:arg0' .. `:arg63', `:path0' .. `:path63'. | |
670 | ((and (keywordp key) | |
671 | (string-match | |
672 | "^:\\(arg\\|path\\)\\([[:digit:]]+\\)$" | |
673 | (symbol-name key))) | |
674 | (setq counter (match-string 2 (symbol-name key)) | |
675 | args (cdr args) | |
676 | value (car args)) | |
677 | (unless (and (<= counter 63) (stringp value)) | |
678 | (signal 'wrong-type-argument | |
679 | (list "Wrong argument" key value))) | |
680 | (format | |
681 | ",arg%s%s='%s'" | |
682 | counter | |
683 | (if (string-equal (match-string 1 (symbol-name key)) "path") | |
684 | "path" "") | |
685 | value)) | |
686 | ;; `:arg-namespace', `:path-namespace'. | |
687 | ((and (keywordp key) | |
688 | (string-match | |
689 | "^:\\(arg\\|path\\)-namespace$" (symbol-name key))) | |
690 | (setq args (cdr args) | |
691 | value (car args)) | |
692 | (unless (stringp value) | |
693 | (signal 'wrong-type-argument | |
694 | (list "Wrong argument" key value))) | |
695 | (format | |
696 | ",%s='%s'" | |
697 | (if (string-equal (match-string 1 (symbol-name key)) "path") | |
698 | "path_namespace" "arg0namespace") | |
699 | value)) | |
700 | ;; `:eavesdrop'. | |
701 | ((eq key :eavesdrop) | |
702 | ",eavesdrop='true'") | |
703 | (t (signal 'wrong-type-argument (list "Wrong argument" key))))) | |
704 | args (cdr args)))) | |
705 | ||
706 | ;; Add the rule to the bus. | |
707 | (condition-case err | |
708 | (dbus-call-method | |
709 | bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus | |
710 | "AddMatch" rule) | |
711 | (dbus-error | |
712 | (if (not (string-match "eavesdrop" rule)) | |
713 | (signal (car err) (cdr err)) | |
714 | ;; The D-Bus spec says we shall fall back to a rule without eavesdrop. | |
715 | (when dbus-debug (message "Removing eavesdrop from rule %s" rule)) | |
716 | (setq rule (replace-regexp-in-string ",eavesdrop='true'" "" rule)) | |
717 | (dbus-call-method | |
718 | bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus | |
719 | "AddMatch" rule)))) | |
98c38bfc | 720 | |
dcbf5805 | 721 | (when dbus-debug (message "Matching rule \"%s\" created" rule)) |
98c38bfc | 722 | |
dcbf5805 MA |
723 | ;; Create a hash table entry. |
724 | (setq key (list :signal bus interface signal) | |
725 | key1 (list uname service path handler rule) | |
726 | value (gethash key dbus-registered-objects-table)) | |
727 | (unless (member key1 value) | |
728 | (puthash key (cons key1 value) dbus-registered-objects-table)) | |
98c38bfc | 729 | |
dcbf5805 MA |
730 | ;; Return the object. |
731 | (list key (list service path handler)))) | |
98c38bfc | 732 | |
dcbf5805 MA |
733 | (defun dbus-register-method |
734 | (bus service path interface method handler &optional dont-register-service) | |
735 | "Register for method METHOD on the D-Bus BUS. | |
736 | ||
737 | BUS is either a Lisp symbol, `:system' or `:session', or a string | |
738 | denoting the bus address. | |
739 | ||
740 | SERVICE is the D-Bus service name of the D-Bus object METHOD is | |
741 | registered for. It must be a known name (See discussion of | |
742 | DONT-REGISTER-SERVICE below). | |
743 | ||
744 | PATH is the D-Bus object path SERVICE is registered (See discussion of | |
745 | DONT-REGISTER-SERVICE below). INTERFACE is the interface offered by | |
746 | SERVICE. It must provide METHOD. | |
747 | ||
748 | HANDLER is a Lisp function to be called when a method call is | |
749 | received. It must accept the input arguments of METHOD. The return | |
750 | value of HANDLER is used for composing the returning D-Bus message. | |
751 | In case HANDLER shall return a reply message with an empty argument | |
752 | list, HANDLER must return the symbol `:ignore'. | |
753 | ||
754 | When DONT-REGISTER-SERVICE is non-nil, the known name SERVICE is not | |
755 | registered. This means that other D-Bus clients have no way of | |
756 | noticing the newly registered method. When interfaces are constructed | |
757 | incrementally by adding single methods or properties at a time, | |
758 | DONT-REGISTER-SERVICE can be used to prevent other clients from | |
759 | discovering the still incomplete interface." | |
760 | ||
761 | ;; Register SERVICE. | |
762 | (unless (or dont-register-service | |
763 | (member service (dbus-list-names bus))) | |
764 | (dbus-register-service bus service)) | |
765 | ||
766 | ;; Create a hash table entry. We use nil for the unique name, | |
767 | ;; because the method might be called from anybody. | |
768 | (let* ((key (list :method bus interface method)) | |
769 | (key1 (list nil service path handler)) | |
770 | (value (gethash key dbus-registered-objects-table))) | |
771 | ||
772 | (unless (member key1 value) | |
773 | (puthash key (cons key1 value) dbus-registered-objects-table)) | |
774 | ||
775 | ;; Return the object. | |
776 | (list key (list service path handler)))) | |
777 | ||
778 | (defun dbus-unregister-object (object) | |
779 | "Unregister OBJECT from D-Bus. | |
780 | OBJECT must be the result of a preceding `dbus-register-method', | |
781 | `dbus-register-property' or `dbus-register-signal' call. It | |
782 | returns `t' if OBJECT has been unregistered, `nil' otherwise. | |
783 | ||
784 | When OBJECT identifies the last method or property, which is | |
785 | registered for the respective service, Emacs releases its | |
786 | association to the service from D-Bus." | |
787 | ;; Check parameter. | |
788 | (unless (and (consp object) (not (null (car object))) (consp (cdr object))) | |
789 | (signal 'wrong-type-argument (list 'D-Bus object))) | |
790 | ||
791 | ;; Find the corresponding entry in the hash table. | |
792 | (let* ((key (car object)) | |
793 | (type (car key)) | |
794 | (bus (cadr key)) | |
795 | (value (cadr object)) | |
796 | (service (car value)) | |
797 | (entry (gethash key dbus-registered-objects-table)) | |
798 | ret) | |
799 | ;; key has the structure (TYPE BUS INTERFACE MEMBER). | |
800 | ;; value has the structure (SERVICE PATH [HANDLER]). | |
801 | ;; entry has the structure ((UNAME SERVICE PATH MEMBER [RULE]) ...). | |
802 | ;; MEMBER is either a string (the handler), or a cons cell (a | |
803 | ;; property value). UNAME and property values are not taken into | |
804 | ;; account for comparison. | |
805 | ||
806 | ;; Loop over the registered functions. | |
807 | (dolist (elt entry) | |
808 | (when (equal | |
809 | value | |
810 | (butlast (cdr elt) (- (length (cdr elt)) (length value)))) | |
811 | (setq ret t) | |
812 | ;; Compute new hash value. If it is empty, remove it from the | |
813 | ;; hash table. | |
814 | (unless (puthash key (delete elt entry) dbus-registered-objects-table) | |
815 | (remhash key dbus-registered-objects-table)) | |
816 | ;; Remove match rule of signals. | |
817 | (when (eq type :signal) | |
818 | (dbus-call-method | |
819 | bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus | |
820 | "RemoveMatch" (nth 4 elt))))) | |
821 | ||
822 | ;; Check, whether there is still a registered function or property | |
823 | ;; for the given service. If not, unregister the service from the | |
824 | ;; bus. | |
825 | (when (and service (memq type '(:method :property)) | |
826 | (not (catch :found | |
827 | (progn | |
828 | (maphash | |
829 | (lambda (k v) | |
830 | (dolist (e v) | |
831 | (ignore-errors | |
832 | (and | |
833 | ;; Bus. | |
834 | (equal bus (cadr k)) | |
835 | ;; Service. | |
836 | (string-equal service (cadr e)) | |
837 | ;; Non-empty object path. | |
f58e0fd5 | 838 | (cl-caddr e) |
dcbf5805 MA |
839 | (throw :found t))))) |
840 | dbus-registered-objects-table) | |
841 | nil)))) | |
842 | (dbus-unregister-service bus service)) | |
843 | ;; Return. | |
844 | ret)) | |
ef6ce14c | 845 | |
5363d8ea | 846 | \f |
82697a45 MA |
847 | ;;; D-Bus type conversion. |
848 | ||
849 | (defun dbus-string-to-byte-array (string) | |
850 | "Transforms STRING to list (:array :byte c1 :byte c2 ...). | |
851 | STRING shall be UTF8 coded." | |
d665fff0 MA |
852 | (if (zerop (length string)) |
853 | '(:array :signature "y") | |
854 | (let (result) | |
855 | (dolist (elt (string-to-list string) (append '(:array) result)) | |
856 | (setq result (append result (list :byte elt))))))) | |
82697a45 | 857 | |
b85eff45 | 858 | (defun dbus-byte-array-to-string (byte-array &optional multibyte) |
82697a45 | 859 | "Transforms BYTE-ARRAY into UTF8 coded string. |
81961e4c | 860 | BYTE-ARRAY must be a list of structure (c1 c2 ...), or a byte |
b85eff45 MA |
861 | array as produced by `dbus-string-to-byte-array'. The resulting |
862 | string is unibyte encoded, unless MULTIBYTE is non-nil." | |
81961e4c | 863 | (apply |
b85eff45 | 864 | (if multibyte 'string 'unibyte-string) |
81961e4c MA |
865 | (if (equal byte-array '(:array :signature "y")) |
866 | nil | |
867 | (let (result) | |
868 | (dolist (elt byte-array result) | |
869 | (when (characterp elt) (setq result (append result `(,elt))))))))) | |
82697a45 MA |
870 | |
871 | (defun dbus-escape-as-identifier (string) | |
872 | "Escape an arbitrary STRING so it follows the rules for a C identifier. | |
873 | The escaped string can be used as object path component, interface element | |
874 | component, bus name component or member name in D-Bus. | |
875 | ||
876 | The escaping consists of replacing all non-alphanumerics, and the | |
877 | first character if it's a digit, with an underscore and two | |
878 | lower-case hex digits: | |
879 | ||
880 | \"0123abc_xyz\\x01\\xff\" -> \"_30123abc_5fxyz_01_ff\" | |
881 | ||
882 | i.e. similar to URI encoding, but with \"_\" taking the role of \"%\", | |
883 | and a smaller allowed set. As a special case, \"\" is escaped to | |
884 | \"_\". | |
885 | ||
886 | Returns the escaped string. Algorithm taken from | |
b85eff45 | 887 | telepathy-glib's `tp_escape_as_identifier'." |
82697a45 MA |
888 | (if (zerop (length string)) |
889 | "_" | |
890 | (replace-regexp-in-string | |
891 | "^[0-9]\\|[^A-Za-z0-9]" | |
892 | (lambda (x) (format "_%2x" (aref x 0))) | |
893 | string))) | |
894 | ||
895 | (defun dbus-unescape-from-identifier (string) | |
b85eff45 MA |
896 | "Retrieve the original string from the encoded STRING as unibyte string. |
897 | STRING must have been encoded with `dbus-escape-as-identifier'." | |
82697a45 MA |
898 | (if (string-equal string "_") |
899 | "" | |
900 | (replace-regexp-in-string | |
901 | "_.." | |
81961e4c | 902 | (lambda (x) (byte-to-string (string-to-number (substring x 1) 16))) |
82697a45 MA |
903 | string))) |
904 | ||
905 | \f | |
5363d8ea MA |
906 | ;;; D-Bus events. |
907 | ||
3a993e3d MA |
908 | (defun dbus-check-event (event) |
909 | "Checks whether EVENT is a well formed D-Bus event. | |
910 | EVENT is a list which starts with symbol `dbus-event': | |
911 | ||
98c38bfc | 912 | (dbus-event BUS TYPE SERIAL SERVICE PATH INTERFACE MEMBER HANDLER &rest ARGS) |
3a993e3d | 913 | |
e49d337b | 914 | BUS identifies the D-Bus the message is coming from. It is |
e73f184c MA |
915 | either a Lisp symbol, `:system' or `:session', or a string |
916 | denoting the bus address. TYPE is the D-Bus message type which | |
917 | has caused the event, SERIAL is the serial number of the received | |
918 | D-Bus message. SERVICE and PATH are the unique name and the | |
919 | object path of the D-Bus object emitting the message. INTERFACE | |
920 | and MEMBER denote the message which has been sent. HANDLER is | |
921 | the function which has been registered for this message. ARGS | |
922 | are the arguments passed to HANDLER, when it is called during | |
923 | event handling in `dbus-handle-event'. | |
3a993e3d MA |
924 | |
925 | This function raises a `dbus-error' signal in case the event is | |
926 | not well formed." | |
927 | (when dbus-debug (message "DBus-Event %s" event)) | |
928 | (unless (and (listp event) | |
929 | (eq (car event) 'dbus-event) | |
5363d8ea | 930 | ;; Bus symbol. |
e73f184c MA |
931 | (or (symbolp (nth 1 event)) |
932 | (stringp (nth 1 event))) | |
98c38bfc MA |
933 | ;; Type. |
934 | (and (natnump (nth 2 event)) | |
935 | (< dbus-message-type-invalid (nth 2 event))) | |
e49d337b | 936 | ;; Serial. |
98c38bfc | 937 | (natnump (nth 3 event)) |
5363d8ea | 938 | ;; Service. |
98c38bfc | 939 | (or (= dbus-message-type-method-return (nth 2 event)) |
ba0b66b0 | 940 | (= dbus-message-type-error (nth 2 event)) |
48198420 DC |
941 | (or (stringp (nth 4 event)) |
942 | (null (nth 4 event)))) | |
e49d337b | 943 | ;; Object path. |
98c38bfc | 944 | (or (= dbus-message-type-method-return (nth 2 event)) |
ba0b66b0 | 945 | (= dbus-message-type-error (nth 2 event)) |
98c38bfc | 946 | (stringp (nth 5 event))) |
e49d337b | 947 | ;; Interface. |
98c38bfc | 948 | (or (= dbus-message-type-method-return (nth 2 event)) |
ba0b66b0 | 949 | (= dbus-message-type-error (nth 2 event)) |
98c38bfc | 950 | (stringp (nth 6 event))) |
e49d337b | 951 | ;; Member. |
98c38bfc | 952 | (or (= dbus-message-type-method-return (nth 2 event)) |
ba0b66b0 | 953 | (= dbus-message-type-error (nth 2 event)) |
98c38bfc | 954 | (stringp (nth 7 event))) |
ef6ce14c | 955 | ;; Handler. |
98c38bfc | 956 | (functionp (nth 8 event))) |
3a993e3d MA |
957 | (signal 'dbus-error (list "Not a valid D-Bus event" event)))) |
958 | ||
959 | ;;;###autoload | |
960 | (defun dbus-handle-event (event) | |
961 | "Handle events from the D-Bus. | |
5363d8ea | 962 | EVENT is a D-Bus event, see `dbus-check-event'. HANDLER, being |
98c38bfc | 963 | part of the event, is called with arguments ARGS. |
35b148ee | 964 | If the HANDLER returns a `dbus-error', it is propagated as return message." |
3a993e3d | 965 | (interactive "e") |
98c38bfc MA |
966 | (condition-case err |
967 | (let (result) | |
ba0b66b0 | 968 | ;; We ignore not well-formed events. |
98c38bfc | 969 | (dbus-check-event event) |
ba0b66b0 MA |
970 | ;; Error messages must be propagated. |
971 | (when (= dbus-message-type-error (nth 2 event)) | |
972 | (signal 'dbus-error (nthcdr 9 event))) | |
973 | ;; Apply the handler. | |
98c38bfc MA |
974 | (setq result (apply (nth 8 event) (nthcdr 9 event))) |
975 | ;; Return a message when it is a message call. | |
976 | (when (= dbus-message-type-method-call (nth 2 event)) | |
977 | (dbus-ignore-errors | |
3dec5c36 MA |
978 | (if (eq result :ignore) |
979 | (dbus-method-return-internal | |
dcbf5805 | 980 | (nth 1 event) (nth 4 event) (nth 3 event)) |
3dec5c36 | 981 | (apply 'dbus-method-return-internal |
dcbf5805 | 982 | (nth 1 event) (nth 4 event) (nth 3 event) |
3dec5c36 | 983 | (if (consp result) result (list result))))))) |
98c38bfc MA |
984 | ;; Error handling. |
985 | (dbus-error | |
986 | ;; Return an error message when it is a message call. | |
987 | (when (= dbus-message-type-method-call (nth 2 event)) | |
988 | (dbus-ignore-errors | |
989 | (dbus-method-error-internal | |
dcbf5805 | 990 | (nth 1 event) (nth 4 event) (nth 3 event) (cadr err)))) |
ba0b66b0 | 991 | ;; Propagate D-Bus error messages. |
d1069532 | 992 | (run-hook-with-args 'dbus-event-error-functions event err) |
48198420 | 993 | (when dbus-debug |
ba0b66b0 | 994 | (signal (car err) (cdr err)))))) |
3a993e3d MA |
995 | |
996 | (defun dbus-event-bus-name (event) | |
997 | "Return the bus name the event is coming from. | |
e73f184c MA |
998 | The result is either a Lisp symbol, `:system' or `:session', or a |
999 | string denoting the bus address. EVENT is a D-Bus event, see | |
1000 | `dbus-check-event'. This function raises a `dbus-error' signal | |
1001 | in case the event is not well formed." | |
3a993e3d | 1002 | (dbus-check-event event) |
ef6ce14c | 1003 | (nth 1 event)) |
3a993e3d | 1004 | |
98c38bfc MA |
1005 | (defun dbus-event-message-type (event) |
1006 | "Return the message type of the corresponding D-Bus message. | |
1007 | The result is a number. EVENT is a D-Bus event, see | |
1008 | `dbus-check-event'. This function raises a `dbus-error' signal | |
1009 | in case the event is not well formed." | |
1010 | (dbus-check-event event) | |
1011 | (nth 2 event)) | |
1012 | ||
e49d337b MA |
1013 | (defun dbus-event-serial-number (event) |
1014 | "Return the serial number of the corresponding D-Bus message. | |
98c38bfc MA |
1015 | The result is a number. The serial number is needed for |
1016 | generating a reply message. EVENT is a D-Bus event, see | |
1017 | `dbus-check-event'. This function raises a `dbus-error' signal | |
1018 | in case the event is not well formed." | |
e49d337b | 1019 | (dbus-check-event event) |
98c38bfc | 1020 | (nth 3 event)) |
e49d337b | 1021 | |
3a993e3d | 1022 | (defun dbus-event-service-name (event) |
5363d8ea | 1023 | "Return the name of the D-Bus object the event is coming from. |
3a993e3d MA |
1024 | The result is a string. EVENT is a D-Bus event, see `dbus-check-event'. |
1025 | This function raises a `dbus-error' signal in case the event is | |
1026 | not well formed." | |
1027 | (dbus-check-event event) | |
98c38bfc | 1028 | (nth 4 event)) |
3a993e3d MA |
1029 | |
1030 | (defun dbus-event-path-name (event) | |
1031 | "Return the object path of the D-Bus object the event is coming from. | |
1032 | The result is a string. EVENT is a D-Bus event, see `dbus-check-event'. | |
1033 | This function raises a `dbus-error' signal in case the event is | |
1034 | not well formed." | |
1035 | (dbus-check-event event) | |
98c38bfc | 1036 | (nth 5 event)) |
3a993e3d MA |
1037 | |
1038 | (defun dbus-event-interface-name (event) | |
1039 | "Return the interface name of the D-Bus object the event is coming from. | |
1040 | The result is a string. EVENT is a D-Bus event, see `dbus-check-event'. | |
1041 | This function raises a `dbus-error' signal in case the event is | |
1042 | not well formed." | |
1043 | (dbus-check-event event) | |
98c38bfc | 1044 | (nth 6 event)) |
3a993e3d MA |
1045 | |
1046 | (defun dbus-event-member-name (event) | |
1047 | "Return the member name the event is coming from. | |
58179cce | 1048 | It is either a signal name or a method name. The result is a |
3a993e3d MA |
1049 | string. EVENT is a D-Bus event, see `dbus-check-event'. This |
1050 | function raises a `dbus-error' signal in case the event is not | |
1051 | well formed." | |
1052 | (dbus-check-event event) | |
98c38bfc | 1053 | (nth 7 event)) |
5363d8ea MA |
1054 | |
1055 | \f | |
1056 | ;;; D-Bus registered names. | |
3a993e3d | 1057 | |
07e52e08 | 1058 | (defun dbus-list-activatable-names (&optional bus) |
3a993e3d | 1059 | "Return the D-Bus service names which can be activated as list. |
07e52e08 MA |
1060 | If BUS is left nil, `:system' is assumed. The result is a list |
1061 | of strings, which is `nil' when there are no activatable service | |
1062 | names at all." | |
246a286b MA |
1063 | (dbus-ignore-errors |
1064 | (dbus-call-method | |
07e52e08 | 1065 | (or bus :system) dbus-service-dbus |
246a286b | 1066 | dbus-path-dbus dbus-interface-dbus "ListActivatableNames"))) |
3a993e3d MA |
1067 | |
1068 | (defun dbus-list-names (bus) | |
1069 | "Return the service names registered at D-Bus BUS. | |
f636d3ca MA |
1070 | The result is a list of strings, which is `nil' when there are no |
1071 | registered service names at all. Well known names are strings | |
1072 | like \"org.freedesktop.DBus\". Names starting with \":\" are | |
1073 | unique names for services." | |
246a286b MA |
1074 | (dbus-ignore-errors |
1075 | (dbus-call-method | |
1076 | bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "ListNames"))) | |
3a993e3d MA |
1077 | |
1078 | (defun dbus-list-known-names (bus) | |
1079 | "Retrieve all services which correspond to a known name in BUS. | |
1080 | A service has a known name if it doesn't start with \":\"." | |
1081 | (let (result) | |
1082 | (dolist (name (dbus-list-names bus) result) | |
1083 | (unless (string-equal ":" (substring name 0 1)) | |
1084 | (add-to-list 'result name 'append))))) | |
1085 | ||
1086 | (defun dbus-list-queued-owners (bus service) | |
f636d3ca MA |
1087 | "Return the unique names registered at D-Bus BUS and queued for SERVICE. |
1088 | The result is a list of strings, or `nil' when there are no | |
1089 | queued name owners service names at all." | |
246a286b MA |
1090 | (dbus-ignore-errors |
1091 | (dbus-call-method | |
1092 | bus dbus-service-dbus dbus-path-dbus | |
1093 | dbus-interface-dbus "ListQueuedOwners" service))) | |
3a993e3d MA |
1094 | |
1095 | (defun dbus-get-name-owner (bus service) | |
1096 | "Return the name owner of SERVICE registered at D-Bus BUS. | |
f636d3ca | 1097 | The result is either a string, or `nil' if there is no name owner." |
246a286b MA |
1098 | (dbus-ignore-errors |
1099 | (dbus-call-method | |
1100 | bus dbus-service-dbus dbus-path-dbus | |
1101 | dbus-interface-dbus "GetNameOwner" service))) | |
3a993e3d | 1102 | |
93fb0645 MA |
1103 | (defun dbus-ping (bus service &optional timeout) |
1104 | "Check whether SERVICE is registered for D-Bus BUS. | |
1105 | TIMEOUT, a nonnegative integer, specifies the maximum number of | |
1106 | milliseconds `dbus-ping' must return. The default value is 25,000. | |
1107 | ||
1108 | Note, that this autoloads SERVICE if it is not running yet. If | |
1109 | it shall be checked whether SERVICE is already running, one shall | |
1110 | apply | |
1111 | ||
1112 | \(member service \(dbus-list-known-names bus))" | |
4ba11bcb MA |
1113 | ;; "Ping" raises a D-Bus error if SERVICE does not exist. |
1114 | ;; Otherwise, it returns silently with `nil'. | |
1115 | (condition-case nil | |
1116 | (not | |
93fb0645 MA |
1117 | (if (natnump timeout) |
1118 | (dbus-call-method | |
1119 | bus service dbus-path-dbus dbus-interface-peer | |
1120 | "Ping" :timeout timeout) | |
1121 | (dbus-call-method | |
1122 | bus service dbus-path-dbus dbus-interface-peer "Ping"))) | |
4ba11bcb MA |
1123 | (dbus-error nil))) |
1124 | ||
f636d3ca MA |
1125 | \f |
1126 | ;;; D-Bus introspection. | |
3a993e3d | 1127 | |
f636d3ca | 1128 | (defun dbus-introspect (bus service path) |
35b148ee | 1129 | "Return all interfaces and sub-nodes of SERVICE, |
f636d3ca MA |
1130 | registered at object path PATH at bus BUS. |
1131 | ||
e73f184c MA |
1132 | BUS is either a Lisp symbol, `:system' or `:session', or a string |
1133 | denoting the bus address. SERVICE must be a known service name, | |
1134 | and PATH must be a valid object path. The last two parameters | |
1135 | are strings. The result, the introspection data, is a string in | |
1136 | XML format." | |
205a7391 | 1137 | ;; We don't want to raise errors. |
246a286b | 1138 | (dbus-ignore-errors |
dcbf5805 MA |
1139 | (dbus-call-method |
1140 | bus service path dbus-interface-introspectable "Introspect" | |
1141 | :timeout 1000))) | |
3a993e3d | 1142 | |
f636d3ca MA |
1143 | (defun dbus-introspect-xml (bus service path) |
1144 | "Return the introspection data of SERVICE in D-Bus BUS at object path PATH. | |
1145 | The data are a parsed list. The root object is a \"node\", | |
1146 | representing the object path PATH. The root object can contain | |
1147 | \"interface\" and further \"node\" objects." | |
1148 | ;; We don't want to raise errors. | |
1149 | (xml-node-name | |
1150 | (ignore-errors | |
1151 | (with-temp-buffer | |
1152 | (insert (dbus-introspect bus service path)) | |
1153 | (xml-parse-region (point-min) (point-max)))))) | |
1154 | ||
1155 | (defun dbus-introspect-get-attribute (object attribute) | |
1156 | "Return the ATTRIBUTE value of D-Bus introspection OBJECT. | |
1157 | ATTRIBUTE must be a string according to the attribute names in | |
1158 | the D-Bus specification." | |
1159 | (xml-get-attribute-or-nil object (intern attribute))) | |
1160 | ||
1161 | (defun dbus-introspect-get-node-names (bus service path) | |
1162 | "Return all node names of SERVICE in D-Bus BUS at object path PATH. | |
1163 | It returns a list of strings. The node names stand for further | |
1164 | object paths of the D-Bus service." | |
1165 | (let ((object (dbus-introspect-xml bus service path)) | |
1166 | result) | |
1167 | (dolist (elt (xml-get-children object 'node) result) | |
1168 | (add-to-list | |
1169 | 'result (dbus-introspect-get-attribute elt "name") 'append)))) | |
1170 | ||
1171 | (defun dbus-introspect-get-all-nodes (bus service path) | |
1172 | "Return all node names of SERVICE in D-Bus BUS at object path PATH. | |
1173 | It returns a list of strings, which are further object paths of SERVICE." | |
1174 | (let ((result (list path))) | |
1175 | (dolist (elt | |
1176 | (dbus-introspect-get-node-names bus service path) | |
1177 | result) | |
1178 | (setq elt (expand-file-name elt path)) | |
1179 | (setq result | |
1180 | (append result (dbus-introspect-get-all-nodes bus service elt)))))) | |
1181 | ||
1182 | (defun dbus-introspect-get-interface-names (bus service path) | |
1183 | "Return all interface names of SERVICE in D-Bus BUS at object path PATH. | |
1184 | It returns a list of strings. | |
1185 | ||
1186 | There will be always the default interface | |
1187 | \"org.freedesktop.DBus.Introspectable\". Another default | |
1188 | interface is \"org.freedesktop.DBus.Properties\". If present, | |
1189 | \"interface\" objects can also have \"property\" objects as | |
1190 | children, beside \"method\" and \"signal\" objects." | |
1191 | (let ((object (dbus-introspect-xml bus service path)) | |
1192 | result) | |
1193 | (dolist (elt (xml-get-children object 'interface) result) | |
1194 | (add-to-list | |
1195 | 'result (dbus-introspect-get-attribute elt "name") 'append)))) | |
1196 | ||
1197 | (defun dbus-introspect-get-interface (bus service path interface) | |
1198 | "Return the INTERFACE of SERVICE in D-Bus BUS at object path PATH. | |
1199 | The return value is an XML object. INTERFACE must be a string, | |
35b148ee JB |
1200 | element of the list returned by `dbus-introspect-get-interface-names'. |
1201 | The resulting \"interface\" object can contain \"method\", \"signal\", | |
f636d3ca MA |
1202 | \"property\" and \"annotation\" children." |
1203 | (let ((elt (xml-get-children | |
1204 | (dbus-introspect-xml bus service path) 'interface))) | |
1205 | (while (and elt | |
1206 | (not (string-equal | |
1207 | interface | |
1208 | (dbus-introspect-get-attribute (car elt) "name")))) | |
1209 | (setq elt (cdr elt))) | |
1210 | (car elt))) | |
1211 | ||
1212 | (defun dbus-introspect-get-method-names (bus service path interface) | |
1213 | "Return a list of strings of all method names of INTERFACE. | |
1214 | SERVICE is a service of D-Bus BUS at object path PATH." | |
1215 | (let ((object (dbus-introspect-get-interface bus service path interface)) | |
1216 | result) | |
1217 | (dolist (elt (xml-get-children object 'method) result) | |
1218 | (add-to-list | |
1219 | 'result (dbus-introspect-get-attribute elt "name") 'append)))) | |
1220 | ||
1221 | (defun dbus-introspect-get-method (bus service path interface method) | |
1222 | "Return method METHOD of interface INTERFACE as XML object. | |
1223 | It must be located at SERVICE in D-Bus BUS at object path PATH. | |
1224 | METHOD must be a string, element of the list returned by | |
1225 | `dbus-introspect-get-method-names'. The resulting \"method\" | |
1226 | object can contain \"arg\" and \"annotation\" children." | |
1227 | (let ((elt (xml-get-children | |
1228 | (dbus-introspect-get-interface bus service path interface) | |
1229 | 'method))) | |
1230 | (while (and elt | |
1231 | (not (string-equal | |
1232 | method (dbus-introspect-get-attribute (car elt) "name")))) | |
1233 | (setq elt (cdr elt))) | |
1234 | (car elt))) | |
1235 | ||
1236 | (defun dbus-introspect-get-signal-names (bus service path interface) | |
1237 | "Return a list of strings of all signal names of INTERFACE. | |
1238 | SERVICE is a service of D-Bus BUS at object path PATH." | |
1239 | (let ((object (dbus-introspect-get-interface bus service path interface)) | |
1240 | result) | |
1241 | (dolist (elt (xml-get-children object 'signal) result) | |
1242 | (add-to-list | |
1243 | 'result (dbus-introspect-get-attribute elt "name") 'append)))) | |
1244 | ||
1245 | (defun dbus-introspect-get-signal (bus service path interface signal) | |
1246 | "Return signal SIGNAL of interface INTERFACE as XML object. | |
1247 | It must be located at SERVICE in D-Bus BUS at object path PATH. | |
1248 | SIGNAL must be a string, element of the list returned by | |
1249 | `dbus-introspect-get-signal-names'. The resulting \"signal\" | |
1250 | object can contain \"arg\" and \"annotation\" children." | |
1251 | (let ((elt (xml-get-children | |
1252 | (dbus-introspect-get-interface bus service path interface) | |
1253 | 'signal))) | |
1254 | (while (and elt | |
1255 | (not (string-equal | |
1256 | signal (dbus-introspect-get-attribute (car elt) "name")))) | |
1257 | (setq elt (cdr elt))) | |
1258 | (car elt))) | |
1259 | ||
1260 | (defun dbus-introspect-get-property-names (bus service path interface) | |
1261 | "Return a list of strings of all property names of INTERFACE. | |
1262 | SERVICE is a service of D-Bus BUS at object path PATH." | |
1263 | (let ((object (dbus-introspect-get-interface bus service path interface)) | |
1264 | result) | |
1265 | (dolist (elt (xml-get-children object 'property) result) | |
1266 | (add-to-list | |
1267 | 'result (dbus-introspect-get-attribute elt "name") 'append)))) | |
1268 | ||
1269 | (defun dbus-introspect-get-property (bus service path interface property) | |
1270 | "This function returns PROPERTY of INTERFACE as XML object. | |
1271 | It must be located at SERVICE in D-Bus BUS at object path PATH. | |
1272 | PROPERTY must be a string, element of the list returned by | |
1273 | `dbus-introspect-get-property-names'. The resulting PROPERTY | |
1274 | object can contain \"annotation\" children." | |
1275 | (let ((elt (xml-get-children | |
1276 | (dbus-introspect-get-interface bus service path interface) | |
1277 | 'property))) | |
1278 | (while (and elt | |
1279 | (not (string-equal | |
1280 | property | |
1281 | (dbus-introspect-get-attribute (car elt) "name")))) | |
1282 | (setq elt (cdr elt))) | |
1283 | (car elt))) | |
1284 | ||
1285 | (defun dbus-introspect-get-annotation-names | |
1286 | (bus service path interface &optional name) | |
1287 | "Return all annotation names as list of strings. | |
1288 | If NAME is `nil', the annotations are children of INTERFACE, | |
1289 | otherwise NAME must be a \"method\", \"signal\", or \"property\" | |
1290 | object, where the annotations belong to." | |
1291 | (let ((object | |
1292 | (if name | |
1293 | (or (dbus-introspect-get-method bus service path interface name) | |
1294 | (dbus-introspect-get-signal bus service path interface name) | |
1295 | (dbus-introspect-get-property bus service path interface name)) | |
1296 | (dbus-introspect-get-interface bus service path interface))) | |
1297 | result) | |
1298 | (dolist (elt (xml-get-children object 'annotation) result) | |
1299 | (add-to-list | |
1300 | 'result (dbus-introspect-get-attribute elt "name") 'append)))) | |
1301 | ||
1302 | (defun dbus-introspect-get-annotation | |
1303 | (bus service path interface name annotation) | |
1304 | "Return ANNOTATION as XML object. | |
1305 | If NAME is `nil', ANNOTATION is a child of INTERFACE, otherwise | |
1306 | NAME must be the name of a \"method\", \"signal\", or | |
1307 | \"property\" object, where the ANNOTATION belongs to." | |
1308 | (let ((elt (xml-get-children | |
1309 | (if name | |
1310 | (or (dbus-introspect-get-method | |
1311 | bus service path interface name) | |
1312 | (dbus-introspect-get-signal | |
1313 | bus service path interface name) | |
1314 | (dbus-introspect-get-property | |
1315 | bus service path interface name)) | |
1316 | (dbus-introspect-get-interface bus service path interface)) | |
1317 | 'annotation))) | |
1318 | (while (and elt | |
1319 | (not (string-equal | |
1320 | annotation | |
1321 | (dbus-introspect-get-attribute (car elt) "name")))) | |
1322 | (setq elt (cdr elt))) | |
1323 | (car elt))) | |
1324 | ||
1325 | (defun dbus-introspect-get-argument-names (bus service path interface name) | |
1326 | "Return a list of all argument names as list of strings. | |
1327 | NAME must be a \"method\" or \"signal\" object. | |
1328 | ||
1329 | Argument names are optional, the function can return `nil' | |
1330 | therefore, even if the method or signal has arguments." | |
1331 | (let ((object | |
1332 | (or (dbus-introspect-get-method bus service path interface name) | |
1333 | (dbus-introspect-get-signal bus service path interface name))) | |
1334 | result) | |
1335 | (dolist (elt (xml-get-children object 'arg) result) | |
1336 | (add-to-list | |
1337 | 'result (dbus-introspect-get-attribute elt "name") 'append)))) | |
1338 | ||
1339 | (defun dbus-introspect-get-argument (bus service path interface name arg) | |
1340 | "Return argument ARG as XML object. | |
35b148ee JB |
1341 | NAME must be a \"method\" or \"signal\" object. ARG must be a string, |
1342 | element of the list returned by `dbus-introspect-get-argument-names'." | |
f636d3ca MA |
1343 | (let ((elt (xml-get-children |
1344 | (or (dbus-introspect-get-method bus service path interface name) | |
1345 | (dbus-introspect-get-signal bus service path interface name)) | |
1346 | 'arg))) | |
1347 | (while (and elt | |
1348 | (not (string-equal | |
1349 | arg (dbus-introspect-get-attribute (car elt) "name")))) | |
1350 | (setq elt (cdr elt))) | |
1351 | (car elt))) | |
1352 | ||
1353 | (defun dbus-introspect-get-signature | |
1354 | (bus service path interface name &optional direction) | |
1355 | "Return signature of a `method' or `signal', represented by NAME, as string. | |
1356 | If NAME is a `method', DIRECTION can be either \"in\" or \"out\". | |
1357 | If DIRECTION is `nil', \"in\" is assumed. | |
1358 | ||
1359 | If NAME is a `signal', and DIRECTION is non-`nil', DIRECTION must | |
1360 | be \"out\"." | |
1361 | ;; For methods, we use "in" as default direction. | |
1362 | (let ((object (or (dbus-introspect-get-method | |
1363 | bus service path interface name) | |
1364 | (dbus-introspect-get-signal | |
1365 | bus service path interface name)))) | |
1366 | (when (and (string-equal | |
1367 | "method" (dbus-introspect-get-attribute object "name")) | |
1368 | (not (stringp direction))) | |
1369 | (setq direction "in")) | |
1370 | ;; In signals, no direction is given. | |
1371 | (when (string-equal "signal" (dbus-introspect-get-attribute object "name")) | |
1372 | (setq direction nil)) | |
1373 | ;; Collect the signatures. | |
1374 | (mapconcat | |
4f91a816 SM |
1375 | (lambda (x) |
1376 | (let ((arg (dbus-introspect-get-argument | |
1377 | bus service path interface name x))) | |
1378 | (if (or (not (stringp direction)) | |
1379 | (string-equal | |
1380 | direction | |
1381 | (dbus-introspect-get-attribute arg "direction"))) | |
1382 | (dbus-introspect-get-attribute arg "type") | |
1383 | ""))) | |
f636d3ca MA |
1384 | (dbus-introspect-get-argument-names bus service path interface name) |
1385 | ""))) | |
3a993e3d | 1386 | |
f636d3ca MA |
1387 | \f |
1388 | ;;; D-Bus properties. | |
3a993e3d | 1389 | |
f636d3ca MA |
1390 | (defun dbus-get-property (bus service path interface property) |
1391 | "Return the value of PROPERTY of INTERFACE. | |
1392 | It will be checked at BUS, SERVICE, PATH. The result can be any | |
1393 | valid D-Bus value, or `nil' if there is no PROPERTY." | |
246a286b | 1394 | (dbus-ignore-errors |
dcbf5805 MA |
1395 | ;; "Get" returns a variant, so we must use the `car'. |
1396 | (car | |
1397 | (dbus-call-method | |
1398 | bus service path dbus-interface-properties | |
1399 | "Get" :timeout 500 interface property)))) | |
f636d3ca MA |
1400 | |
1401 | (defun dbus-set-property (bus service path interface property value) | |
1402 | "Set value of PROPERTY of INTERFACE to VALUE. | |
1403 | It will be checked at BUS, SERVICE, PATH. When the value has | |
1404 | been set successful, the result is VALUE. Otherwise, `nil' is | |
1405 | returned." | |
1406 | (dbus-ignore-errors | |
dcbf5805 MA |
1407 | ;; "Set" requires a variant. |
1408 | (dbus-call-method | |
1409 | bus service path dbus-interface-properties | |
1410 | "Set" :timeout 500 interface property (list :variant value)) | |
1411 | ;; Return VALUE. | |
1412 | (dbus-get-property bus service path interface property))) | |
f636d3ca MA |
1413 | |
1414 | (defun dbus-get-all-properties (bus service path interface) | |
1415 | "Return all properties of INTERFACE at BUS, SERVICE, PATH. | |
1416 | The result is a list of entries. Every entry is a cons of the | |
1417 | name of the property, and its value. If there are no properties, | |
1418 | `nil' is returned." | |
f636d3ca | 1419 | (dbus-ignore-errors |
b172ed20 | 1420 | ;; "GetAll" returns "a{sv}". |
f636d3ca | 1421 | (let (result) |
b172ed20 | 1422 | (dolist (dict |
dcbf5805 | 1423 | (dbus-call-method |
b172ed20 MA |
1424 | bus service path dbus-interface-properties |
1425 | "GetAll" :timeout 500 interface) | |
f636d3ca | 1426 | result) |
f58e0fd5 | 1427 | (add-to-list 'result (cons (car dict) (cl-caadr dict)) 'append))))) |
b172ed20 MA |
1428 | |
1429 | (defun dbus-register-property | |
6388924a MA |
1430 | (bus service path interface property access value |
1431 | &optional emits-signal dont-register-service) | |
b172ed20 MA |
1432 | "Register property PROPERTY on the D-Bus BUS. |
1433 | ||
e73f184c MA |
1434 | BUS is either a Lisp symbol, `:system' or `:session', or a string |
1435 | denoting the bus address. | |
b172ed20 MA |
1436 | |
1437 | SERVICE is the D-Bus service name of the D-Bus. It must be a | |
6388924a MA |
1438 | known name (See discussion of DONT-REGISTER-SERVICE below). |
1439 | ||
1440 | PATH is the D-Bus object path SERVICE is registered (See | |
1441 | discussion of DONT-REGISTER-SERVICE below). INTERFACE is the | |
1442 | name of the interface used at PATH, PROPERTY is the name of the | |
1443 | property of INTERFACE. ACCESS indicates, whether the property | |
1444 | can be changed by other services via D-Bus. It must be either | |
1445 | the symbol `:read' or `:readwrite'. VALUE is the initial value | |
1446 | of the property, it can be of any valid type (see | |
b172ed20 MA |
1447 | `dbus-call-method' for details). |
1448 | ||
1449 | If PROPERTY already exists on PATH, it will be overwritten. For | |
1450 | properties with access type `:read' this is the only way to | |
1451 | change their values. Properties with access type `:readwrite' | |
1452 | can be changed by `dbus-set-property'. | |
1453 | ||
1454 | The interface \"org.freedesktop.DBus.Properties\" is added to | |
1455 | PATH, including a default handler for the \"Get\", \"GetAll\" and | |
b1ce08da MA |
1456 | \"Set\" methods of this interface. When EMITS-SIGNAL is non-nil, |
1457 | the signal \"PropertiesChanged\" is sent when the property is | |
6388924a MA |
1458 | changed by `dbus-set-property'. |
1459 | ||
1460 | When DONT-REGISTER-SERVICE is non-nil, the known name SERVICE is | |
1461 | not registered. This means that other D-Bus clients have no way | |
1462 | of noticing the newly registered property. When interfaces are | |
1463 | constructed incrementally by adding single methods or properties | |
1464 | at a time, DONT-REGISTER-SERVICE can be used to prevent other | |
1465 | clients from discovering the still incomplete interface." | |
b172ed20 | 1466 | (unless (member access '(:read :readwrite)) |
dcbf5805 | 1467 | (signal 'wrong-type-argument (list "Access type invalid" access))) |
b172ed20 | 1468 | |
0a203b61 | 1469 | ;; Add handlers for the three property-related methods. |
b172ed20 | 1470 | (dbus-register-method |
0a203b61 | 1471 | bus service path dbus-interface-properties "Get" |
1a27c64e | 1472 | 'dbus-property-handler 'dont-register) |
b172ed20 | 1473 | (dbus-register-method |
1a27c64e MA |
1474 | bus service path dbus-interface-properties "GetAll" |
1475 | 'dbus-property-handler 'dont-register) | |
b172ed20 | 1476 | (dbus-register-method |
1a27c64e MA |
1477 | bus service path dbus-interface-properties "Set" |
1478 | 'dbus-property-handler 'dont-register) | |
0a203b61 | 1479 | |
dcbf5805 MA |
1480 | ;; Register SERVICE. |
1481 | (unless (or dont-register-service (member service (dbus-list-names bus))) | |
0a203b61 | 1482 | (dbus-register-service bus service)) |
b172ed20 | 1483 | |
b1ce08da MA |
1484 | ;; Send the PropertiesChanged signal. |
1485 | (when emits-signal | |
1486 | (dbus-send-signal | |
1487 | bus service path dbus-interface-properties "PropertiesChanged" | |
dcbf5805 | 1488 | `((:dict-entry ,property (:variant ,value))) |
b1ce08da MA |
1489 | '(:array))) |
1490 | ||
b172ed20 MA |
1491 | ;; Create a hash table entry. We use nil for the unique name, |
1492 | ;; because the property might be accessed from anybody. | |
dcbf5805 | 1493 | (let ((key (list :property bus interface property)) |
b1ce08da MA |
1494 | (val |
1495 | (list | |
1496 | (list | |
1497 | nil service path | |
1498 | (cons | |
1499 | (if emits-signal (list access :emits-signal) (list access)) | |
1500 | value))))) | |
b172ed20 MA |
1501 | (puthash key val dbus-registered-objects-table) |
1502 | ||
1503 | ;; Return the object. | |
1504 | (list key (list service path)))) | |
1505 | ||
1506 | (defun dbus-property-handler (&rest args) | |
35b148ee | 1507 | "Default handler for the \"org.freedesktop.DBus.Properties\" interface. |
dcbf5805 | 1508 | It will be registered for all objects created by `dbus-register-property'." |
b172ed20 | 1509 | (let ((bus (dbus-event-bus-name last-input-event)) |
b1ce08da | 1510 | (service (dbus-event-service-name last-input-event)) |
b172ed20 MA |
1511 | (path (dbus-event-path-name last-input-event)) |
1512 | (method (dbus-event-member-name last-input-event)) | |
1513 | (interface (car args)) | |
1514 | (property (cadr args))) | |
1515 | (cond | |
1516 | ;; "Get" returns a variant. | |
1517 | ((string-equal method "Get") | |
dcbf5805 | 1518 | (let ((entry (gethash (list :property bus interface property) |
b1ce08da MA |
1519 | dbus-registered-objects-table))) |
1520 | (when (string-equal path (nth 2 (car entry))) | |
dcbf5805 | 1521 | `((:variant ,(cdar (last (car entry)))))))) |
b172ed20 MA |
1522 | |
1523 | ;; "Set" expects a variant. | |
1524 | ((string-equal method "Set") | |
b1ce08da | 1525 | (let* ((value (caar (cddr args))) |
dcbf5805 | 1526 | (entry (gethash (list :property bus interface property) |
b1ce08da MA |
1527 | dbus-registered-objects-table)) |
1528 | ;; The value of the hash table is a list; in case of | |
1529 | ;; properties it contains just one element (UNAME SERVICE | |
1530 | ;; PATH OBJECT). OBJECT is a cons cell of a list, which | |
1531 | ;; contains a list of annotations (like :read, | |
1532 | ;; :read-write, :emits-signal), and the value of the | |
1533 | ;; property. | |
1534 | (object (car (last (car entry))))) | |
1535 | (unless (consp object) | |
b172ed20 MA |
1536 | (signal 'dbus-error |
1537 | (list "Property not registered at path" property path))) | |
b1ce08da | 1538 | (unless (member :readwrite (car object)) |
b172ed20 MA |
1539 | (signal 'dbus-error |
1540 | (list "Property not writable at path" property path))) | |
dcbf5805 | 1541 | (puthash (list :property bus interface property) |
b1ce08da MA |
1542 | (list (append (butlast (car entry)) |
1543 | (list (cons (car object) value)))) | |
b172ed20 | 1544 | dbus-registered-objects-table) |
b1ce08da MA |
1545 | ;; Send the "PropertiesChanged" signal. |
1546 | (when (member :emits-signal (car object)) | |
1547 | (dbus-send-signal | |
1548 | bus service path dbus-interface-properties "PropertiesChanged" | |
dcbf5805 | 1549 | `((:dict-entry ,property (:variant ,value))) |
b1ce08da MA |
1550 | '(:array))) |
1551 | ;; Return empty reply. | |
b172ed20 MA |
1552 | :ignore)) |
1553 | ||
1554 | ;; "GetAll" returns "a{sv}". | |
1555 | ((string-equal method "GetAll") | |
1556 | (let (result) | |
1557 | (maphash | |
1558 | (lambda (key val) | |
dcbf5805 | 1559 | (when (and (equal (butlast key) (list :property bus interface)) |
b172ed20 | 1560 | (string-equal path (nth 2 (car val))) |
31bb373f | 1561 | (not (functionp (car (last (car val)))))) |
b172ed20 MA |
1562 | (add-to-list |
1563 | 'result | |
1564 | (list :dict-entry | |
1565 | (car (last key)) | |
1566 | (list :variant (cdar (last (car val)))))))) | |
1567 | dbus-registered-objects-table) | |
052e28ac MA |
1568 | ;; Return the result, or an empty array. |
1569 | (list :array (or result '(:signature "{sv}")))))))) | |
b172ed20 | 1570 | |
dcbf5805 MA |
1571 | \f |
1572 | ;;; D-Bus object manager. | |
1573 | ||
1574 | (defun dbus-get-all-managed-objects (bus service path) | |
1575 | "Return all objects at BUS, SERVICE, PATH, and the children of PATH. | |
1576 | The result is a list of objects. Every object is a cons of an | |
1577 | existing path name, and the list of available interface objects. | |
1578 | An interface object is another cons, which car is the interface | |
1579 | name, and the cdr is the list of properties as returned by | |
205a7391 | 1580 | `dbus-get-all-properties' for that path and interface. Example: |
dcbf5805 MA |
1581 | |
1582 | \(dbus-get-all-managed-objects :session \"org.gnome.SettingsDaemon\" \"/\") | |
1583 | ||
1584 | => \(\(\"/org/gnome/SettingsDaemon/MediaKeys\" | |
1585 | \(\"org.gnome.SettingsDaemon.MediaKeys\") | |
1586 | \(\"org.freedesktop.DBus.Peer\") | |
1587 | \(\"org.freedesktop.DBus.Introspectable\") | |
1588 | \(\"org.freedesktop.DBus.Properties\") | |
1589 | \(\"org.freedesktop.DBus.ObjectManager\")) | |
1590 | \(\"/org/gnome/SettingsDaemon/Power\" | |
1591 | \(\"org.gnome.SettingsDaemon.Power.Keyboard\") | |
1592 | \(\"org.gnome.SettingsDaemon.Power.Screen\") | |
1593 | \(\"org.gnome.SettingsDaemon.Power\" | |
1594 | \(\"Icon\" . \". GThemedIcon battery-full-charged-symbolic \") | |
1595 | \(\"Tooltip\" . \"Laptop battery is charged\")) | |
1596 | \(\"org.freedesktop.DBus.Peer\") | |
1597 | \(\"org.freedesktop.DBus.Introspectable\") | |
1598 | \(\"org.freedesktop.DBus.Properties\") | |
1599 | \(\"org.freedesktop.DBus.ObjectManager\")) | |
1600 | ...) | |
1601 | ||
1602 | If possible, \"org.freedesktop.DBus.ObjectManager.GetManagedObjects\" | |
1603 | is used for retrieving the information. Otherwise, the information | |
1604 | is collected via \"org.freedesktop.DBus.Introspectable.Introspect\" | |
1605 | and \"org.freedesktop.DBus.Properties.GetAll\", which is slow." | |
1606 | (let ((result | |
1607 | ;; Direct call. Fails, if the target does not support the | |
1608 | ;; object manager interface. | |
1609 | (dbus-ignore-errors | |
1610 | (dbus-call-method | |
1611 | bus service path dbus-interface-objectmanager | |
1612 | "GetManagedObjects" :timeout 1000)))) | |
1613 | ||
1614 | (if result | |
1615 | ;; Massage the returned structure. | |
1616 | (dolist (entry result result) | |
1617 | ;; "a{oa{sa{sv}}}". | |
1618 | (dolist (entry1 (cdr entry)) | |
1619 | ;; "a{sa{sv}}". | |
1620 | (dolist (entry2 entry1) | |
1621 | ;; "a{sv}". | |
1622 | (if (cadr entry2) | |
1623 | ;; "sv". | |
1624 | (dolist (entry3 (cadr entry2)) | |
f58e0fd5 | 1625 | (setcdr entry3 (cl-caadr entry3))) |
dcbf5805 MA |
1626 | (setcdr entry2 nil))))) |
1627 | ||
1628 | ;; Fallback: collect the information. Slooow! | |
1629 | (dolist (object | |
1630 | (dbus-introspect-get-all-nodes bus service path) | |
1631 | result) | |
1632 | (let (result1) | |
1633 | (dolist | |
1634 | (interface | |
1635 | (dbus-introspect-get-interface-names bus service object) | |
1636 | result1) | |
1637 | (add-to-list | |
1638 | 'result1 | |
1639 | (cons interface | |
1640 | (dbus-get-all-properties bus service object interface)))) | |
1641 | (when result1 | |
1642 | (add-to-list 'result (cons object result1)))))))) | |
1643 | ||
1644 | (defun dbus-managed-objects-handler () | |
1645 | "Default handler for the \"org.freedesktop.DBus.ObjectManager\" interface. | |
1646 | It will be registered for all objects created by `dbus-register-method'." | |
1647 | (let* ((last-input-event last-input-event) | |
1648 | (bus (dbus-event-bus-name last-input-event)) | |
dcbf5805 MA |
1649 | (path (dbus-event-path-name last-input-event))) |
1650 | ;; "GetManagedObjects" returns "a{oa{sa{sv}}}". | |
1651 | (let (interfaces result) | |
1652 | ||
1653 | ;; Check for object path wildcard interfaces. | |
1654 | (maphash | |
1655 | (lambda (key val) | |
1656 | (when (and (equal (butlast key 2) (list :method bus)) | |
1657 | (null (nth 2 (car-safe val)))) | |
1658 | (add-to-list 'interfaces (nth 2 key)))) | |
1659 | dbus-registered-objects-table) | |
1660 | ||
1661 | ;; Check all registered object paths. | |
1662 | (maphash | |
1663 | (lambda (key val) | |
6c42fc3e | 1664 | (let ((object (or (nth 2 (car-safe val)) ""))) |
dcbf5805 MA |
1665 | (when (and (equal (butlast key 2) (list :method bus)) |
1666 | (string-prefix-p path object)) | |
1667 | (dolist (interface (cons (nth 2 key) interfaces)) | |
1668 | (unless (assoc object result) | |
1669 | (add-to-list 'result (list object))) | |
1670 | (unless (assoc interface (cdr (assoc object result))) | |
1671 | (setcdr | |
1672 | (assoc object result) | |
1673 | (append | |
1674 | (list (cons | |
1675 | interface | |
1676 | ;; We simulate "org.freedesktop.DBus.Properties.GetAll" | |
1677 | ;; by using an appropriate D-Bus event. | |
1678 | (let ((last-input-event | |
1679 | (append | |
1680 | (butlast last-input-event 4) | |
1681 | (list object dbus-interface-properties | |
1682 | "GetAll" 'dbus-property-handler)))) | |
1683 | (dbus-property-handler interface)))) | |
1684 | (cdr (assoc object result))))))))) | |
1685 | dbus-registered-objects-table) | |
1686 | ||
1687 | ;; Return the result, or an empty array. | |
1688 | (list | |
1689 | :array | |
1690 | (or | |
1691 | (mapcar | |
1692 | (lambda (x) | |
1693 | (list | |
1694 | :dict-entry :object-path (car x) | |
1695 | (cons :array (mapcar (lambda (y) (cons :dict-entry y)) (cdr x))))) | |
1696 | result) | |
1697 | '(:signature "{oa{sa{sv}}}")))))) | |
1698 | ||
48198420 DC |
1699 | (defun dbus-handle-bus-disconnect () |
1700 | "React to a bus disconnection. | |
1701 | BUS is the bus that disconnected. This routine unregisters all | |
1702 | handlers on the given bus and causes all synchronous calls | |
1703 | pending at the time of disconnect to fail." | |
1704 | (let ((bus (dbus-event-bus-name last-input-event)) | |
1705 | (keys-to-remove)) | |
1706 | (maphash | |
1707 | (lambda (key value) | |
1708 | (when (and (eq (nth 0 key) :serial) | |
1709 | (eq (nth 1 key) bus)) | |
1710 | (run-hook-with-args | |
1711 | 'dbus-event-error-functions | |
1712 | (list 'dbus-event | |
1713 | bus | |
1714 | dbus-message-type-error | |
1715 | (nth 2 key) | |
1716 | nil | |
1717 | nil | |
1718 | nil | |
1719 | nil | |
1720 | value) | |
1721 | '(dbus-error "Bus disconnected")) | |
1722 | (push key keys-to-remove))) | |
1723 | dbus-registered-objects-table) | |
1724 | (dolist (key keys-to-remove) | |
1725 | (remhash key dbus-registered-objects-table)))) | |
1726 | ||
1727 | (defun dbus-init-bus (bus &optional private) | |
1728 | "Establish the connection to D-Bus BUS. | |
1729 | ||
1730 | BUS can be either the symbol `:system' or the symbol `:session', or it | |
1731 | can be a string denoting the address of the corresponding bus. For | |
1732 | the system and session buses, this function is called when loading | |
1733 | `dbus.el', there is no need to call it again. | |
1734 | ||
1735 | The function returns a number, which counts the connections this Emacs | |
1736 | session has established to the BUS under the same unique name (see | |
1737 | `dbus-get-unique-name'). It depends on the libraries Emacs is linked | |
1738 | with, and on the environment Emacs is running. For example, if Emacs | |
1739 | is linked with the gtk toolkit, and it runs in a GTK-aware environment | |
1740 | like Gnome, another connection might already be established. | |
1741 | ||
1742 | When PRIVATE is non-nil, a new connection is established instead of | |
1743 | reusing an existing one. It results in a new unique name at the bus. | |
1744 | This can be used, if it is necessary to distinguish from another | |
1745 | connection used in the same Emacs process, like the one established by | |
1746 | GTK+. It should be used with care for at least the `:system' and | |
1747 | `:session' buses, because other Emacs Lisp packages might already use | |
1748 | this connection to those buses. | |
1749 | " | |
1750 | (dbus-init-bus-1 bus private) | |
1751 | (dbus-register-signal bus nil | |
1752 | "/org/freedesktop/DBus/Local" | |
1753 | "org.freedesktop.DBus.Local" | |
1754 | "Disconnected" | |
1755 | #'dbus-handle-bus-disconnect)) | |
1756 | ||
b172ed20 | 1757 | \f |
dcbf5805 | 1758 | ;; Initialize `:system' and `:session' buses. This adds their file |
720c7cd6 MA |
1759 | ;; descriptors to input_wait_mask, in order to detect incoming |
1760 | ;; messages immediately. | |
9e846523 MA |
1761 | (when (featurep 'dbusbind) |
1762 | (dbus-ignore-errors | |
dcbf5805 MA |
1763 | (dbus-init-bus :system)) |
1764 | (dbus-ignore-errors | |
9e846523 | 1765 | (dbus-init-bus :session))) |
720c7cd6 | 1766 | |
3a993e3d MA |
1767 | (provide 'dbus) |
1768 | ||
dcbf5805 MA |
1769 | ;;; TODO: |
1770 | ||
1771 | ;; * Implement org.freedesktop.DBus.ObjectManager.InterfacesAdded and | |
1772 | ;; org.freedesktop.DBus.ObjectManager.InterfacesRemoved. | |
1773 | ||
3a993e3d | 1774 | ;;; dbus.el ends here |