Commit | Line | Data |
---|---|---|
3a993e3d MA |
1 | ;;; dbus.el --- Elisp bindings for D-Bus. |
2 | ||
7d1112ae | 3 | ;; Copyright (C) 2007, 2008 Free Software Foundation, Inc. |
3a993e3d MA |
4 | |
5 | ;; Author: Michael Albinus <michael.albinus@gmx.de> | |
6 | ;; Keywords: comm, hardware | |
7 | ||
8 | ;; This file is part of GNU Emacs. | |
9 | ||
874a927a | 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
3a993e3d | 11 | ;; it under the terms of the GNU General Public License as published by |
874a927a GM |
12 | ;; the Free Software Foundation, either version 3 of the License, or |
13 | ;; (at your option) any later version. | |
3a993e3d MA |
14 | |
15 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;; GNU General Public License for more details. | |
19 | ||
20 | ;; You should have received a copy of the GNU General Public License | |
874a927a | 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
3a993e3d MA |
22 | |
23 | ;;; Commentary: | |
24 | ||
25 | ;; This package provides language bindings for the D-Bus API. D-Bus | |
26 | ;; is a message bus system, a simple way for applications to talk to | |
27 | ;; one another. See <http://dbus.freedesktop.org/> for details. | |
28 | ||
29 | ;; Low-level language bindings are implemented in src/dbusbind.c. | |
30 | ||
31 | ;;; Code: | |
32 | ||
7bb7efbd | 33 | ;; D-Bus support in the Emacs core can be disabled with configuration |
6981d00a MA |
34 | ;; option "--without-dbus". Declare used subroutines and variables. |
35 | (declare-function dbus-call-method "dbusbind.c") | |
36 | (declare-function dbus-register-signal "dbusbind.c") | |
37 | (defvar dbus-debug) | |
38 | (defvar dbus-registered-functions-table) | |
39 | ||
40 | ;; Pacify byte compiler. | |
41 | (eval-when-compile | |
42 | (require 'cl)) | |
7bb7efbd | 43 | |
3a993e3d MA |
44 | (require 'xml) |
45 | ||
46 | (defconst dbus-service-dbus "org.freedesktop.DBus" | |
47 | "The bus name used to talk to the bus itself.") | |
48 | ||
49 | (defconst dbus-path-dbus "/org/freedesktop/DBus" | |
50 | "The object path used to talk to the bus itself.") | |
51 | ||
52 | (defconst dbus-interface-dbus "org.freedesktop.DBus" | |
53 | "The interface exported by the object with `dbus-service-dbus' and `dbus-path-dbus'.") | |
54 | ||
4ba11bcb MA |
55 | (defconst dbus-interface-peer (concat dbus-interface-dbus ".Peer") |
56 | "The interface for peer objects.") | |
57 | ||
58 | (defconst dbus-interface-introspectable | |
59 | (concat dbus-interface-dbus ".Introspectable") | |
3a993e3d MA |
60 | "The interface supported by introspectable objects.") |
61 | ||
246a286b MA |
62 | (defmacro dbus-ignore-errors (&rest body) |
63 | "Execute BODY; signal D-Bus error when `dbus-debug' is non-nil. | |
64 | Otherwise, return result of last form in BODY, or all other errors." | |
65 | `(condition-case err | |
66 | (progn ,@body) | |
67 | (dbus-error (when dbus-debug (signal (car err) (cdr err)))))) | |
68 | ||
69 | (put 'dbus-ignore-errors 'lisp-indent-function 0) | |
70 | (put 'dbus-ignore-errors 'edebug-form-spec '(form symbolp body)) | |
71 | (font-lock-add-keywords 'emacs-lisp-mode '("\\<dbus-ignore-errors\\>")) | |
72 | ||
5363d8ea MA |
73 | \f |
74 | ;;; Hash table of registered functions. | |
75 | ||
79945ac1 MA |
76 | ;; We create it here. So we have a simple test in dbusbind.c, whether |
77 | ;; the Lisp code has been loaded. | |
78 | (setq dbus-registered-functions-table (make-hash-table :test 'equal)) | |
5363d8ea | 79 | |
ef6ce14c | 80 | (defun dbus-list-hash-table () |
e49d337b | 81 | "Returns all registered member registrations to D-Bus. |
ef6ce14c MA |
82 | The return value is a list, with elements of kind (KEY . VALUE). |
83 | See `dbus-registered-functions-table' for a description of the | |
84 | hash table." | |
85 | (let (result) | |
86 | (maphash | |
87 | '(lambda (key value) (add-to-list 'result (cons key value) 'append)) | |
88 | dbus-registered-functions-table) | |
89 | result)) | |
90 | ||
246a286b MA |
91 | (defun dbus-unregister-object (object) |
92 | "Unregister OBJECT from D-Bus. | |
93 | OBJECT must be the result of a preceding `dbus-register-method' | |
94 | or `dbus-register-signal' call. It returns t if OBJECT has been | |
95 | unregistered, nil otherwise." | |
96 | ;; Check parameter. | |
97 | (unless (and (consp object) (not (null (car object))) (consp (cdr object))) | |
98 | (signal 'wrong-type-argument (list 'D-Bus object))) | |
99 | ||
100 | ;; Find the corresponding entry in the hash table. | |
101 | (let* ((key (car object)) | |
102 | (value (gethash key dbus-registered-functions-table))) | |
103 | ;; Loop over the registered functions. | |
104 | (while (consp value) | |
105 | ;; (car value) has the structure (UNAME SERVICE PATH HANDLER). | |
106 | ;; (cdr object) has the structure ((SERVICE PATH HANDLER) ...). | |
107 | (if (not (equal (cdr (car value)) (car (cdr object)))) | |
108 | (setq value (cdr value)) | |
109 | ;; Compute new hash value. If it is empty, remove it from | |
110 | ;; hash table. | |
111 | (unless | |
112 | (puthash | |
113 | key | |
114 | (delete (car value) (gethash key dbus-registered-functions-table)) | |
115 | dbus-registered-functions-table) | |
116 | (remhash key dbus-registered-functions-table)) | |
117 | (setq value t))) | |
118 | value)) | |
119 | ||
0e0c4247 | 120 | (defun dbus-name-owner-changed-handler (&rest args) |
e49d337b | 121 | "Reapplies all member registrations to D-Bus. |
ef6ce14c MA |
122 | This handler is applied when a \"NameOwnerChanged\" signal has |
123 | arrived. SERVICE is the object name for which the name owner has | |
124 | been changed. OLD-OWNER is the previous owner of SERVICE, or the | |
125 | empty string if SERVICE was not owned yet. NEW-OWNER is the new | |
0e0c4247 MA |
126 | owner of SERVICE, or the empty string if SERVICE looses any name owner. |
127 | ||
128 | usage: (dbus-name-owner-changed-handler service old-owner new-owner)" | |
ef6ce14c | 129 | (save-match-data |
0e0c4247 MA |
130 | ;; Check the arguments. We should silently ignore it when they |
131 | ;; are wrong. | |
132 | (if (and (= (length args) 3) | |
133 | (stringp (car args)) | |
134 | (stringp (cadr args)) | |
135 | (stringp (caddr args))) | |
136 | (let ((service (car args)) | |
137 | (old-owner (cadr args)) | |
138 | (new-owner (caddr args))) | |
139 | ;; Check whether SERVICE is a known name. | |
140 | (when (not (string-match "^:" service)) | |
141 | (maphash | |
142 | '(lambda (key value) | |
143 | (dolist (elt value) | |
e49d337b | 144 | ;; key has the structure (BUS INTERFACE MEMBER). |
0e0c4247 MA |
145 | ;; elt has the structure (UNAME SERVICE PATH HANDLER). |
146 | (when (string-equal old-owner (car elt)) | |
147 | ;; Remove old key, and add new entry with changed name. | |
7d1112ae | 148 | (dbus-unregister-object (list key (cdr elt))) |
0e0c4247 MA |
149 | ;; Maybe we could arrange the lists a little bit better |
150 | ;; that we don't need to extract every single element? | |
151 | (dbus-register-signal | |
152 | ;; BUS SERVICE PATH | |
153 | (nth 0 key) (nth 1 elt) (nth 2 elt) | |
e49d337b | 154 | ;; INTERFACE MEMBER HANDLER |
0e0c4247 MA |
155 | (nth 1 key) (nth 2 key) (nth 3 elt))))) |
156 | (copy-hash-table dbus-registered-functions-table)))) | |
157 | ;; The error is reported only in debug mode. | |
158 | (when dbus-debug | |
159 | (signal | |
160 | 'dbus-error | |
161 | (cons | |
162 | (format "Wrong arguments of %s.NameOwnerChanged" dbus-interface-dbus) | |
163 | args)))))) | |
ef6ce14c MA |
164 | |
165 | ;; Register the handler. | |
6981d00a | 166 | (ignore-errors |
246a286b MA |
167 | (dbus-register-signal |
168 | :system dbus-service-dbus dbus-path-dbus dbus-interface-dbus | |
169 | "NameOwnerChanged" 'dbus-name-owner-changed-handler) | |
170 | (dbus-register-signal | |
171 | :session dbus-service-dbus dbus-path-dbus dbus-interface-dbus | |
172 | "NameOwnerChanged" 'dbus-name-owner-changed-handler)) | |
ef6ce14c | 173 | |
5363d8ea MA |
174 | \f |
175 | ;;; D-Bus events. | |
176 | ||
3a993e3d MA |
177 | (defun dbus-check-event (event) |
178 | "Checks whether EVENT is a well formed D-Bus event. | |
179 | EVENT is a list which starts with symbol `dbus-event': | |
180 | ||
e49d337b | 181 | (dbus-event BUS SERIAL SERVICE PATH INTERFACE MEMBER HANDLER &rest ARGS) |
3a993e3d | 182 | |
e49d337b MA |
183 | BUS identifies the D-Bus the message is coming from. It is |
184 | either the symbol `:system' or the symbol `:session'. SERIAL is | |
185 | the serial number of the received D-Bus message if it is a method | |
186 | call, or nil. SERVICE and PATH are the unique name and the | |
187 | object path of the D-Bus object emitting the message. INTERFACE | |
188 | and MEMBER denote the message which has been sent. HANDLER is | |
189 | the function which has been registered for this message. ARGS | |
190 | are the arguments passed to HANDLER, when it is called during | |
191 | event handling in `dbus-handle-event'. | |
3a993e3d MA |
192 | |
193 | This function raises a `dbus-error' signal in case the event is | |
194 | not well formed." | |
195 | (when dbus-debug (message "DBus-Event %s" event)) | |
196 | (unless (and (listp event) | |
197 | (eq (car event) 'dbus-event) | |
5363d8ea | 198 | ;; Bus symbol. |
ef6ce14c | 199 | (symbolp (nth 1 event)) |
e49d337b MA |
200 | ;; Serial. |
201 | (or (natnump (nth 2 event)) (null (nth 2 event))) | |
5363d8ea | 202 | ;; Service. |
ef6ce14c | 203 | (stringp (nth 3 event)) |
e49d337b | 204 | ;; Object path. |
ef6ce14c | 205 | (stringp (nth 4 event)) |
e49d337b | 206 | ;; Interface. |
ef6ce14c | 207 | (stringp (nth 5 event)) |
e49d337b MA |
208 | ;; Member. |
209 | (stringp (nth 6 event)) | |
ef6ce14c | 210 | ;; Handler. |
e49d337b | 211 | (functionp (nth 7 event))) |
3a993e3d MA |
212 | (signal 'dbus-error (list "Not a valid D-Bus event" event)))) |
213 | ||
214 | ;;;###autoload | |
215 | (defun dbus-handle-event (event) | |
216 | "Handle events from the D-Bus. | |
5363d8ea MA |
217 | EVENT is a D-Bus event, see `dbus-check-event'. HANDLER, being |
218 | part of the event, is called with arguments ARGS." | |
3a993e3d | 219 | (interactive "e") |
5363d8ea MA |
220 | ;; We don't want to raise an error, because this function is called |
221 | ;; in the event handling loop. | |
246a286b MA |
222 | (dbus-ignore-errors |
223 | (let (result) | |
224 | (dbus-check-event event) | |
225 | (setq result (apply (nth 7 event) (nthcdr 8 event))) | |
226 | (unless (consp result) (setq result (cons result nil))) | |
227 | ;; Return a message when serial is not nil. | |
228 | (when (not (null (nth 2 event))) | |
229 | (apply 'dbus-method-return-internal | |
230 | (nth 1 event) (nth 2 event) (nth 3 event) result))))) | |
3a993e3d MA |
231 | |
232 | (defun dbus-event-bus-name (event) | |
233 | "Return the bus name the event is coming from. | |
234 | The result is either the symbol `:system' or the symbol `:session'. | |
235 | EVENT is a D-Bus event, see `dbus-check-event'. This function | |
236 | raises a `dbus-error' signal in case the event is not well | |
237 | formed." | |
238 | (dbus-check-event event) | |
ef6ce14c | 239 | (nth 1 event)) |
3a993e3d | 240 | |
e49d337b MA |
241 | (defun dbus-event-serial-number (event) |
242 | "Return the serial number of the corresponding D-Bus message. | |
243 | The result is a number in case the D-Bus message is a method | |
244 | call, or nil for all other mesage types. The serial number is | |
245 | needed for generating a reply message. EVENT is a D-Bus event, | |
246 | see `dbus-check-event'. This function raises a `dbus-error' | |
247 | signal in case the event is not well formed." | |
248 | (dbus-check-event event) | |
249 | (nth 2 event)) | |
250 | ||
3a993e3d | 251 | (defun dbus-event-service-name (event) |
5363d8ea | 252 | "Return the name of the D-Bus object the event is coming from. |
3a993e3d MA |
253 | The result is a string. EVENT is a D-Bus event, see `dbus-check-event'. |
254 | This function raises a `dbus-error' signal in case the event is | |
255 | not well formed." | |
256 | (dbus-check-event event) | |
e49d337b | 257 | (nth 3 event)) |
3a993e3d MA |
258 | |
259 | (defun dbus-event-path-name (event) | |
260 | "Return the object path of the D-Bus object the event is coming from. | |
261 | The result is a string. EVENT is a D-Bus event, see `dbus-check-event'. | |
262 | This function raises a `dbus-error' signal in case the event is | |
263 | not well formed." | |
264 | (dbus-check-event event) | |
e49d337b | 265 | (nth 4 event)) |
3a993e3d MA |
266 | |
267 | (defun dbus-event-interface-name (event) | |
268 | "Return the interface name of the D-Bus object the event is coming from. | |
269 | The result is a string. EVENT is a D-Bus event, see `dbus-check-event'. | |
270 | This function raises a `dbus-error' signal in case the event is | |
271 | not well formed." | |
272 | (dbus-check-event event) | |
e49d337b | 273 | (nth 5 event)) |
3a993e3d MA |
274 | |
275 | (defun dbus-event-member-name (event) | |
276 | "Return the member name the event is coming from. | |
277 | It is either a signal name or a method name. The result is is a | |
278 | string. EVENT is a D-Bus event, see `dbus-check-event'. This | |
279 | function raises a `dbus-error' signal in case the event is not | |
280 | well formed." | |
281 | (dbus-check-event event) | |
e49d337b | 282 | (nth 6 event)) |
5363d8ea MA |
283 | |
284 | \f | |
285 | ;;; D-Bus registered names. | |
3a993e3d MA |
286 | |
287 | (defun dbus-list-activatable-names () | |
288 | "Return the D-Bus service names which can be activated as list. | |
289 | The result is a list of strings, which is nil when there are no | |
290 | activatable service names at all." | |
246a286b MA |
291 | (dbus-ignore-errors |
292 | (dbus-call-method | |
293 | :system dbus-service-dbus | |
294 | dbus-path-dbus dbus-interface-dbus "ListActivatableNames"))) | |
3a993e3d MA |
295 | |
296 | (defun dbus-list-names (bus) | |
297 | "Return the service names registered at D-Bus BUS. | |
298 | The result is a list of strings, which is nil when there are no | |
299 | registered service names at all. Well known names are strings like | |
300 | \"org.freedesktop.DBus\". Names starting with \":\" are unique names | |
301 | for services." | |
246a286b MA |
302 | (dbus-ignore-errors |
303 | (dbus-call-method | |
304 | bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "ListNames"))) | |
3a993e3d MA |
305 | |
306 | (defun dbus-list-known-names (bus) | |
307 | "Retrieve all services which correspond to a known name in BUS. | |
308 | A service has a known name if it doesn't start with \":\"." | |
309 | (let (result) | |
310 | (dolist (name (dbus-list-names bus) result) | |
311 | (unless (string-equal ":" (substring name 0 1)) | |
312 | (add-to-list 'result name 'append))))) | |
313 | ||
314 | (defun dbus-list-queued-owners (bus service) | |
315 | "Return the unique names registered at D-Bus BUS and queued for SERVICE. | |
316 | The result is a list of strings, or nil when there are no queued name | |
317 | owners service names at all." | |
246a286b MA |
318 | (dbus-ignore-errors |
319 | (dbus-call-method | |
320 | bus dbus-service-dbus dbus-path-dbus | |
321 | dbus-interface-dbus "ListQueuedOwners" service))) | |
3a993e3d MA |
322 | |
323 | (defun dbus-get-name-owner (bus service) | |
324 | "Return the name owner of SERVICE registered at D-Bus BUS. | |
325 | The result is either a string, or nil if there is no name owner." | |
246a286b MA |
326 | (dbus-ignore-errors |
327 | (dbus-call-method | |
328 | bus dbus-service-dbus dbus-path-dbus | |
329 | dbus-interface-dbus "GetNameOwner" service))) | |
3a993e3d | 330 | |
4ba11bcb MA |
331 | (defun dbus-ping (bus service) |
332 | "Check whether SERVICE is registered for D-Bus BUS." | |
333 | ;; "Ping" raises a D-Bus error if SERVICE does not exist. | |
334 | ;; Otherwise, it returns silently with `nil'. | |
335 | (condition-case nil | |
336 | (not | |
337 | (dbus-call-method bus service dbus-path-dbus dbus-interface-peer "Ping")) | |
338 | (dbus-error nil))) | |
339 | ||
3a993e3d MA |
340 | (defun dbus-introspect (bus service path) |
341 | "Return the introspection data of SERVICE in D-Bus BUS at object path PATH. | |
342 | The data are in XML format. | |
343 | ||
344 | Example: | |
345 | ||
346 | \(dbus-introspect | |
347 | :system \"org.freedesktop.Hal\" | |
ef6ce14c | 348 | \"/org/freedesktop/Hal/devices/computer\")" |
246a286b MA |
349 | (dbus-ignore-errors |
350 | (dbus-call-method | |
351 | bus service path dbus-interface-introspectable "Introspect"))) | |
3a993e3d MA |
352 | |
353 | (if nil ;; Must be reworked. Shall we offer D-Bus signatures at all? | |
354 | (defun dbus-get-signatures (bus interface signal) | |
355 | "Retrieve SIGNAL's type signatures from D-Bus. | |
356 | The result is a list of SIGNAL's type signatures. Example: | |
357 | ||
358 | \(\"s\" \"b\" \"ai\"\) | |
359 | ||
360 | This list represents 3 parameters of SIGNAL. The first parameter | |
361 | is of type string, the second parameter is of type boolean, and | |
362 | the third parameter is of type array of integer. | |
363 | ||
364 | If INTERFACE or SIGNAL do not exist, or if they do not support | |
365 | the D-Bus method org.freedesktop.DBus.Introspectable.Introspect, | |
366 | the function returns nil." | |
246a286b MA |
367 | (dbus-ignore-errors |
368 | (let ((introspect-xml | |
369 | (with-temp-buffer | |
370 | (insert (dbus-introspect bus interface)) | |
371 | (xml-parse-region (point-min) (point-max)))) | |
372 | node interfaces signals args result) | |
373 | ;; Get the root node. | |
374 | (setq node (xml-node-name introspect-xml)) | |
375 | ;; Get all interfaces. | |
376 | (setq interfaces (xml-get-children node 'interface)) | |
377 | (while interfaces | |
378 | (when (string-equal (xml-get-attribute (car interfaces) 'name) | |
379 | interface) | |
380 | ;; That's the requested interface. Check for signals. | |
381 | (setq signals (xml-get-children (car interfaces) 'signal)) | |
382 | (while signals | |
383 | (when (string-equal (xml-get-attribute (car signals) 'name) signal) | |
384 | ;; The signal we are looking for. | |
385 | (setq args (xml-get-children (car signals) 'arg)) | |
386 | (while args | |
387 | (unless (xml-get-attribute (car args) 'type) | |
388 | ;; This shouldn't happen, let's escape. | |
389 | (signal 'dbus-error nil)) | |
390 | ;; We append the signature. | |
391 | (setq | |
392 | result (append result | |
393 | (list (xml-get-attribute (car args) 'type)))) | |
394 | (setq args (cdr args))) | |
395 | (setq signals nil)) | |
396 | (setq signals (cdr signals))) | |
397 | (setq interfaces nil)) | |
398 | (setq interfaces (cdr interfaces))) | |
399 | result))) | |
3a993e3d MA |
400 | ) ;; (if nil ... |
401 | ||
402 | (provide 'dbus) | |
403 | ||
79f10da0 | 404 | ;; arch-tag: a47caf84-9162-4811-90cc-5d388e37b9bd |
3a993e3d | 405 | ;;; dbus.el ends here |