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