Commit | Line | Data |
---|---|---|
033b73e2 MA |
1 | /* Elisp bindings for D-Bus. |
2 | Copyright (C) 2007 Free Software Foundation, Inc. | |
3 | ||
4 | This file is part of GNU Emacs. | |
5 | ||
6 | GNU Emacs is free software; you can redistribute it and/or modify | |
7 | it under the terms of the GNU General Public License as published by | |
8 | the Free Software Foundation; either version 3, or (at your option) | |
9 | any later version. | |
10 | ||
11 | GNU Emacs is distributed in the hope that it will be useful, | |
12 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | GNU General Public License for more details. | |
15 | ||
16 | You should have received a copy of the GNU General Public License | |
17 | along with GNU Emacs; see the file COPYING. If not, write to | |
18 | the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, | |
19 | Boston, MA 02110-1301, USA. */ | |
20 | ||
21 | #include "config.h" | |
22 | ||
23 | #ifdef HAVE_DBUS | |
24 | #include <stdlib.h> | |
25 | #include <dbus/dbus.h> | |
26 | #include "lisp.h" | |
27 | #include "frame.h" | |
28 | #include "termhooks.h" | |
29 | #include "keyboard.h" | |
30 | ||
31 | \f | |
32 | /* Subroutines. */ | |
33 | Lisp_Object Qdbus_get_unique_name; | |
34 | Lisp_Object Qdbus_call_method; | |
35 | Lisp_Object Qdbus_send_signal; | |
36 | Lisp_Object Qdbus_register_signal; | |
37 | Lisp_Object Qdbus_unregister_signal; | |
38 | ||
39 | /* D-Bus error symbol. */ | |
40 | Lisp_Object Qdbus_error; | |
41 | ||
42 | /* Lisp symbols of the system and session buses. */ | |
43 | Lisp_Object Qdbus_system_bus, Qdbus_session_bus; | |
44 | ||
45 | /* Obarray which keeps interned symbols. */ | |
46 | Lisp_Object Vdbus_intern_symbols; | |
47 | ||
48 | /* Whether to debug D-Bus. */ | |
49 | Lisp_Object Vdbus_debug; | |
50 | ||
51 | \f | |
52 | /* We use "xd_" and "XD_" as prefix for all internal symbols, because | |
53 | we don't want to poison other namespaces with "dbus_". */ | |
54 | ||
55 | /* Create a new interned symbol which represents a function handler. | |
56 | bus is a Lisp symbol, either :system or :session. interface and | |
57 | member are both Lisp strings. | |
58 | ||
59 | D-Bus sends messages, which are captured by Emacs in the main loop, | |
60 | converted into an event then. Emacs must identify a message from | |
61 | D-Bus, in order to call the right Lisp function when the event is | |
62 | handled in the event handler function of dbus.el. | |
63 | ||
64 | A D-Bus message is determined at least by the D-Bus bus it is | |
65 | raised from (system bus or session bus), the interface and the | |
66 | method the message belongs to. There could be even more properties | |
67 | for determination, but that isn't implemented yet. | |
68 | ||
69 | The approach is to create a new interned Lisp symbol once there is | |
70 | a registration request for a given signal, which is a special D-Bus | |
71 | message. The symbol's name is a concatenation of the bus name, | |
72 | interface name and method name of the signal; the function cell is | |
73 | the Lisp function to be called when such a signal arrives. Since | |
74 | this code runs in the main loop, receiving input, it must be | |
75 | performant. */ | |
76 | #define XD_SYMBOL_INTERN_SYMBOL(symbol, bus, interface, member) \ | |
77 | { \ | |
78 | XD_DEBUG_VALID_LISP_OBJECT_P (bus); \ | |
79 | XD_DEBUG_VALID_LISP_OBJECT_P (interface); \ | |
80 | XD_DEBUG_VALID_LISP_OBJECT_P (member); \ | |
81 | char s[1024]; \ | |
82 | strcpy (s, SDATA (SYMBOL_NAME (bus))); \ | |
83 | strcat (s, "."); \ | |
84 | strcat (s, SDATA (interface)); \ | |
85 | strcat (s, "."); \ | |
86 | strcat (s, SDATA (member)); \ | |
87 | symbol = Fintern (build_string (s), Vdbus_intern_symbols); \ | |
88 | } | |
89 | ||
90 | /* Raise a Lisp error from a D-Bus error. */ | |
91 | #define XD_ERROR(error) \ | |
92 | { \ | |
93 | char s[1024]; \ | |
94 | strcpy (s, error.message); \ | |
95 | dbus_error_free (&error); \ | |
96 | /* Remove the trailing newline. */ \ | |
97 | if (strchr (s, '\n') != NULL) \ | |
98 | s[strlen (s) - 1] = '\0'; \ | |
99 | xsignal1 (Qdbus_error, build_string (s)); \ | |
100 | } | |
101 | ||
102 | /* Macros for debugging. In order to enable them, build with | |
103 | "make MYCPPFLAGS='-DDBUS_DEBUG'". */ | |
104 | #ifdef DBUS_DEBUG | |
105 | #define XD_DEBUG_MESSAGE(...) \ | |
106 | { \ | |
107 | char s[1024]; \ | |
108 | sprintf (s, __VA_ARGS__); \ | |
109 | printf ("%s: %s\n", __func__, s); \ | |
110 | message ("%s: %s", __func__, s); \ | |
111 | } | |
112 | #define XD_DEBUG_VALID_LISP_OBJECT_P(object) \ | |
113 | if (!valid_lisp_object_p (object)) \ | |
114 | { \ | |
115 | XD_DEBUG_MESSAGE ("%s Assertion failure", __LINE__); \ | |
116 | xsignal1 (Qdbus_error, build_string ("Assertion failure")); \ | |
117 | } | |
118 | ||
119 | #else /* !DBUS_DEBUG */ | |
120 | #define XD_DEBUG_MESSAGE(...) \ | |
121 | if (!NILP (Vdbus_debug)) \ | |
122 | { \ | |
123 | char s[1024]; \ | |
124 | sprintf (s, __VA_ARGS__); \ | |
125 | message ("%s: %s", __func__, s); \ | |
126 | } | |
127 | #define XD_DEBUG_VALID_LISP_OBJECT_P(object) | |
128 | #endif | |
129 | ||
130 | /* Determine the DBusType of a given Lisp object. It is used to | |
131 | convert Lisp objects, being arguments of `dbus-call-method' or | |
132 | `dbus-send-signal', into corresponding C values appended as | |
133 | arguments to a D-Bus message. */ | |
134 | #define XD_LISP_OBJECT_TO_DBUS_TYPE(object) \ | |
135 | (EQ (object, Qt) || EQ (object, Qnil)) ? DBUS_TYPE_BOOLEAN : \ | |
136 | (NATNUMP (object)) ? DBUS_TYPE_UINT32 : \ | |
137 | (INTEGERP (object)) ? DBUS_TYPE_INT32 : \ | |
138 | (FLOATP (object)) ? DBUS_TYPE_DOUBLE : \ | |
139 | (STRINGP (object)) ? DBUS_TYPE_STRING : \ | |
140 | DBUS_TYPE_INVALID | |
141 | ||
142 | /* Extract C value from Lisp OBJECT. DTYPE must be a valid DBusType, | |
143 | as detected by XD_LISP_OBJECT_TO_DBUS_TYPE. Compound types are not | |
144 | supported (yet). It is used to convert Lisp objects, being | |
145 | arguments of `dbus-call-method' or `dbus-send-signal', into | |
146 | corresponding C values appended as arguments to a D-Bus | |
147 | message. */ | |
148 | char * | |
149 | xd_retrieve_value (dtype, object) | |
150 | uint dtype; | |
151 | Lisp_Object object; | |
152 | { | |
153 | ||
154 | XD_DEBUG_VALID_LISP_OBJECT_P (object); | |
155 | switch (dtype) | |
156 | { | |
157 | case DBUS_TYPE_BOOLEAN: | |
158 | XD_DEBUG_MESSAGE ("%d %s", dtype, (NILP (object)) ? "false" : "true"); | |
159 | return (NILP (object)) ? (char *) FALSE : (char *) TRUE; | |
160 | case DBUS_TYPE_UINT32: | |
161 | XD_DEBUG_MESSAGE ("%d %d", dtype, XUINT (object)); | |
162 | return (char *) XUINT (object); | |
163 | case DBUS_TYPE_INT32: | |
164 | XD_DEBUG_MESSAGE ("%d %d", dtype, XINT (object)); | |
165 | return (char *) XINT (object); | |
166 | case DBUS_TYPE_DOUBLE: | |
167 | XD_DEBUG_MESSAGE ("%d %d", dtype, XFLOAT (object)); | |
168 | return (char *) XFLOAT (object); | |
169 | case DBUS_TYPE_STRING: | |
170 | XD_DEBUG_MESSAGE ("%d %s", dtype, SDATA (object)); | |
171 | return SDATA (object); | |
172 | default: | |
173 | XD_DEBUG_MESSAGE ("DBus-Type %d not supported", dtype); | |
174 | return NULL; | |
175 | } | |
176 | } | |
177 | ||
178 | /* Retrieve C value from a DBusMessageIter structure ITER, and return | |
179 | a converted Lisp object. The type DTYPE of the argument of the | |
180 | D-Bus message must be a valid DBusType. Compound D-Bus types are | |
181 | partly supported; they result always in a Lisp list. */ | |
182 | Lisp_Object | |
183 | xd_retrieve_arg (dtype, iter) | |
184 | uint dtype; | |
185 | DBusMessageIter *iter; | |
186 | { | |
187 | ||
188 | switch (dtype) | |
189 | { | |
190 | case DBUS_TYPE_BOOLEAN: | |
191 | { | |
192 | dbus_bool_t val; | |
193 | dbus_message_iter_get_basic (iter, &val); | |
194 | XD_DEBUG_MESSAGE ("%d %s", dtype, (val == FALSE) ? "false" : "true"); | |
195 | return (val == FALSE) ? Qnil : Qt; | |
196 | } | |
197 | case DBUS_TYPE_INT32: | |
198 | case DBUS_TYPE_UINT32: | |
199 | { | |
200 | dbus_uint32_t val; | |
201 | dbus_message_iter_get_basic (iter, &val); | |
202 | XD_DEBUG_MESSAGE ("%d %d", dtype, val); | |
203 | return make_number (val); | |
204 | } | |
205 | case DBUS_TYPE_STRING: | |
206 | case DBUS_TYPE_OBJECT_PATH: | |
207 | { | |
208 | char *val; | |
209 | dbus_message_iter_get_basic (iter, &val); | |
210 | XD_DEBUG_MESSAGE ("%d %s", dtype, val); | |
211 | return build_string (val); | |
212 | } | |
213 | case DBUS_TYPE_ARRAY: | |
214 | case DBUS_TYPE_VARIANT: | |
215 | case DBUS_TYPE_STRUCT: | |
216 | case DBUS_TYPE_DICT_ENTRY: | |
217 | { | |
218 | Lisp_Object result; | |
219 | struct gcpro gcpro1; | |
220 | result = Qnil; | |
221 | GCPRO1 (result); | |
222 | DBusMessageIter subiter; | |
223 | int subtype; | |
224 | dbus_message_iter_recurse (iter, &subiter); | |
225 | while ((subtype = dbus_message_iter_get_arg_type (&subiter)) | |
226 | != DBUS_TYPE_INVALID) | |
227 | { | |
228 | result = Fcons (xd_retrieve_arg (subtype, &subiter), result); | |
229 | dbus_message_iter_next (&subiter); | |
230 | } | |
231 | RETURN_UNGCPRO (Fnreverse (result)); | |
232 | } | |
233 | default: | |
234 | XD_DEBUG_MESSAGE ("DBusType %d not supported", dtype); | |
235 | return Qnil; | |
236 | } | |
237 | } | |
238 | ||
239 | ||
240 | /* Initialize D-Bus connection. BUS is a Lisp symbol, either :system | |
241 | or :session. It tells which D-Bus to be initialized. */ | |
242 | DBusConnection * | |
243 | xd_initialize (bus) | |
244 | Lisp_Object bus; | |
245 | { | |
246 | DBusConnection *connection; | |
247 | DBusError derror; | |
248 | ||
249 | /* Parameter check. */ | |
250 | CHECK_SYMBOL (bus); | |
251 | if (!((EQ (bus, Qdbus_system_bus)) || (EQ (bus, Qdbus_session_bus)))) | |
252 | xsignal2 (Qdbus_error, build_string ("Wrong bus name"), bus); | |
253 | ||
254 | /* Open a connection to the bus. */ | |
255 | dbus_error_init (&derror); | |
256 | ||
257 | if (EQ (bus, Qdbus_system_bus)) | |
258 | connection = dbus_bus_get (DBUS_BUS_SYSTEM, &derror); | |
259 | else | |
260 | connection = dbus_bus_get (DBUS_BUS_SESSION, &derror); | |
261 | ||
262 | if (dbus_error_is_set (&derror)) | |
263 | XD_ERROR (derror); | |
264 | ||
265 | if (connection == NULL) | |
266 | xsignal2 (Qdbus_error, build_string ("No connection"), bus); | |
267 | ||
268 | /* Return the result. */ | |
269 | return connection; | |
270 | } | |
271 | ||
272 | DEFUN ("dbus-get-unique-name", Fdbus_get_unique_name, Sdbus_get_unique_name, | |
273 | 1, 1, 0, | |
274 | doc: /* Return the unique name of Emacs registered at D-Bus BUS as string. */) | |
275 | (bus) | |
276 | Lisp_Object bus; | |
277 | { | |
278 | DBusConnection *connection; | |
279 | char name[1024]; | |
280 | ||
281 | /* Check parameters. */ | |
282 | CHECK_SYMBOL (bus); | |
283 | ||
284 | /* Open a connection to the bus. */ | |
285 | connection = xd_initialize (bus); | |
286 | ||
287 | /* Request the name. */ | |
288 | strcpy (name, dbus_bus_get_unique_name (connection)); | |
289 | if (name == NULL) | |
290 | xsignal1 (Qdbus_error, build_string ("No unique name available")); | |
291 | ||
292 | /* Return. */ | |
293 | return build_string (name); | |
294 | } | |
295 | ||
296 | DEFUN ("dbus-call-method", Fdbus_call_method, Sdbus_call_method, 5, MANY, 0, | |
297 | doc: /* Call METHOD on the D-Bus BUS. | |
298 | ||
299 | BUS is either the symbol `:system' or the symbol `:session'. | |
300 | ||
301 | SERVICE is the D-Bus service name to be used. PATH is the D-Bus | |
302 | object path SERVICE is registered at. INTERFACE is an interface | |
303 | offered by SERVICE. It must provide METHOD. | |
304 | ||
305 | All other arguments ARGS are passed to METHOD as arguments. They are | |
306 | converted into D-Bus types via the following rules: | |
307 | ||
308 | t and nil => DBUS_TYPE_BOOLEAN | |
309 | number => DBUS_TYPE_UINT32 | |
310 | integer => DBUS_TYPE_INT32 | |
311 | float => DBUS_TYPE_DOUBLE | |
312 | string => DBUS_TYPE_STRING | |
313 | ||
314 | Other Lisp objects are not supported as input arguments of METHOD. | |
315 | ||
316 | `dbus-call-method' returns the resulting values of METHOD as a list of | |
317 | Lisp objects. The type conversion happens the other direction as for | |
318 | input arguments. Additionally to the types supported for input | |
319 | arguments, the D-Bus compound types DBUS_TYPE_ARRAY, DBUS_TYPE_VARIANT, | |
320 | DBUS_TYPE_STRUCT and DBUS_TYPE_DICT_ENTRY are accepted. All of them | |
321 | are converted into a list of Lisp objects which correspond to the | |
322 | elements of the D-Bus container. Example: | |
323 | ||
324 | \(dbus-call-method | |
325 | :session "GetKeyField" "org.gnome.seahorse" | |
326 | "/org/gnome/seahorse/keys/openpgp" "org.gnome.seahorse.Keys" | |
327 | "openpgp:657984B8C7A966DD" "simple-name") | |
328 | ||
329 | => (t ("Philip R. Zimmermann")) | |
330 | ||
331 | If the result of the METHOD call is just one value, the converted Lisp | |
332 | object is returned instead of a list containing this single Lisp object. | |
333 | ||
334 | \(dbus-call-method | |
335 | :system "GetPropertyString" "org.freedesktop.Hal" | |
336 | "/org/freedesktop/Hal/devices/computer" "org.freedesktop.Hal.Device" | |
337 | "system.kernel.machine") | |
338 | ||
339 | => "i686" | |
340 | ||
341 | usage: (dbus-call-method BUS METHOD SERVICE PATH INTERFACE &rest ARGS) */) | |
342 | (nargs, args) | |
343 | int nargs; | |
344 | register Lisp_Object *args; | |
345 | { | |
346 | Lisp_Object bus, method, service, path, interface; | |
347 | Lisp_Object result; | |
348 | struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; | |
349 | DBusConnection *connection; | |
350 | DBusMessage *dmessage; | |
351 | DBusMessage *reply; | |
352 | DBusMessageIter iter; | |
353 | DBusError derror; | |
354 | uint dtype; | |
355 | int i; | |
356 | char *value; | |
357 | ||
358 | /* Check parameters. */ | |
359 | bus = args[0]; | |
360 | method = args[1]; | |
361 | service = args[2]; | |
362 | path = args[3]; | |
363 | interface = args[4]; | |
364 | ||
365 | CHECK_SYMBOL (bus); | |
366 | CHECK_STRING (method); | |
367 | CHECK_STRING (service); | |
368 | CHECK_STRING (path); | |
369 | CHECK_STRING (interface); | |
370 | GCPRO5 (bus, method, service, path, interface); | |
371 | ||
372 | XD_DEBUG_MESSAGE ("%s %s %s %s", | |
373 | SDATA (method), | |
374 | SDATA (service), | |
375 | SDATA (path), | |
376 | SDATA (interface)); | |
377 | ||
378 | /* Open a connection to the bus. */ | |
379 | connection = xd_initialize (bus); | |
380 | ||
381 | /* Create the message. */ | |
382 | dmessage = dbus_message_new_method_call (SDATA (service), | |
383 | SDATA (path), | |
384 | SDATA (interface), | |
385 | SDATA (method)); | |
386 | if (dmessage == NULL) | |
387 | { | |
388 | UNGCPRO; | |
389 | xsignal1 (Qdbus_error, build_string ("Unable to create a new message")); | |
390 | } | |
391 | ||
392 | UNGCPRO; | |
393 | ||
394 | /* Append parameters to the message. */ | |
395 | for (i = 5; i < nargs; ++i) | |
396 | { | |
397 | ||
398 | XD_DEBUG_VALID_LISP_OBJECT_P (args[i]); | |
399 | XD_DEBUG_MESSAGE ("Parameter%d %s", | |
400 | i-4, | |
401 | SDATA (format2 ("%s", args[i], Qnil))); | |
402 | ||
403 | dtype = XD_LISP_OBJECT_TO_DBUS_TYPE (args[i]); | |
404 | if (dtype == DBUS_TYPE_INVALID) | |
405 | xsignal2 (Qdbus_error, build_string ("Not a valid argument"), args[i]); | |
406 | ||
407 | value = (char *) xd_retrieve_value (dtype, args[i]); | |
408 | ||
409 | if (!dbus_message_append_args (dmessage, | |
410 | dtype, | |
411 | &value, | |
412 | DBUS_TYPE_INVALID)) | |
413 | xsignal2 (Qdbus_error, | |
414 | build_string ("Unable to append argument"), args[i]); | |
415 | } | |
416 | ||
417 | /* Send the message. */ | |
418 | dbus_error_init (&derror); | |
419 | reply = dbus_connection_send_with_reply_and_block (connection, | |
420 | dmessage, | |
421 | -1, | |
422 | &derror); | |
423 | ||
424 | if (dbus_error_is_set (&derror)) | |
425 | XD_ERROR (derror); | |
426 | ||
427 | if (reply == NULL) | |
428 | xsignal1 (Qdbus_error, build_string ("No reply")); | |
429 | ||
430 | XD_DEBUG_MESSAGE ("Message sent"); | |
431 | ||
432 | /* Collect the results. */ | |
433 | result = Qnil; | |
434 | GCPRO1 (result); | |
435 | ||
436 | if (!dbus_message_iter_init (reply, &iter)) | |
437 | { | |
438 | UNGCPRO; | |
439 | xsignal1 (Qdbus_error, build_string ("Cannot read reply")); | |
440 | } | |
441 | ||
442 | /* Loop over the parameters of the D-Bus reply message. Construct a | |
443 | Lisp list, which is returned by `dbus-call-method'. */ | |
444 | while ((dtype = dbus_message_iter_get_arg_type (&iter)) != DBUS_TYPE_INVALID) | |
445 | { | |
446 | result = Fcons (xd_retrieve_arg (dtype, &iter), result); | |
447 | dbus_message_iter_next (&iter); | |
448 | } | |
449 | ||
450 | /* Cleanup. */ | |
451 | dbus_message_unref (dmessage); | |
452 | dbus_message_unref (reply); | |
453 | ||
454 | /* Return the result. If there is only one single Lisp object, | |
455 | return it as-it-is, otherwise return the reversed list. */ | |
456 | if (XUINT (Flength (result)) == 1) | |
457 | RETURN_UNGCPRO (XCAR (result)); | |
458 | else | |
459 | RETURN_UNGCPRO (Fnreverse (result)); | |
460 | } | |
461 | ||
462 | DEFUN ("dbus-send-signal", Fdbus_send_signal, Sdbus_send_signal, 5, MANY, 0, | |
463 | doc: /* Send signal SIGNAL on the D-Bus BUS. | |
464 | ||
465 | BUS is either the symbol `:system' or the symbol `:session'. | |
466 | ||
467 | SERVICE is the D-Bus service name SIGNAL is sent from. PATH is the | |
468 | D-Bus object path SERVICE is registered at. INTERFACE is an interface | |
469 | offered by SERVICE. It must provide signal SIGNAL. | |
470 | ||
471 | All other arguments ARGS are passed to SIGNAL as arguments. They are | |
472 | converted into D-Bus types via the following rules: | |
473 | ||
474 | t and nil => DBUS_TYPE_BOOLEAN | |
475 | number => DBUS_TYPE_UINT32 | |
476 | integer => DBUS_TYPE_INT32 | |
477 | float => DBUS_TYPE_DOUBLE | |
478 | string => DBUS_TYPE_STRING | |
479 | ||
480 | Other Lisp objects are not supported as arguments of SIGNAL. | |
481 | ||
482 | Example: | |
483 | ||
484 | \(dbus-send-signal | |
485 | :session "Started" "org.gnu.emacs" "/org/gnu/emacs" "org.gnu.emacs"))) | |
486 | ||
487 | usage: (dbus-send-signal BUS SIGNAL SERVICE PATH INTERFACE &rest ARGS) */) | |
488 | (nargs, args) | |
489 | int nargs; | |
490 | register Lisp_Object *args; | |
491 | { | |
492 | Lisp_Object bus, signal, service, path, interface; | |
493 | struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; | |
494 | DBusConnection *connection; | |
495 | DBusMessage *dmessage; | |
496 | uint dtype; | |
497 | int i; | |
498 | char *value; | |
499 | ||
500 | /* Check parameters. */ | |
501 | bus = args[0]; | |
502 | signal = args[1]; | |
503 | service = args[2]; | |
504 | path = args[3]; | |
505 | interface = args[4]; | |
506 | ||
507 | CHECK_SYMBOL (bus); | |
508 | CHECK_STRING (signal); | |
509 | CHECK_STRING (service); | |
510 | CHECK_STRING (path); | |
511 | CHECK_STRING (interface); | |
512 | GCPRO5 (bus, signal, service, path, interface); | |
513 | ||
514 | XD_DEBUG_MESSAGE ("%s %s %s %s", | |
515 | SDATA (signal), | |
516 | SDATA (service), | |
517 | SDATA (path), | |
518 | SDATA (interface)); | |
519 | ||
520 | /* Open a connection to the bus. */ | |
521 | connection = xd_initialize (bus); | |
522 | ||
523 | /* Create the message. */ | |
524 | dmessage = dbus_message_new_signal (SDATA (path), | |
525 | SDATA (interface), | |
526 | SDATA (signal)); | |
527 | if (dmessage == NULL) | |
528 | { | |
529 | UNGCPRO; | |
530 | xsignal1 (Qdbus_error, build_string ("Unable to create a new message")); | |
531 | } | |
532 | ||
533 | UNGCPRO; | |
534 | ||
535 | /* Append parameters to the message. */ | |
536 | for (i = 5; i < nargs; ++i) | |
537 | { | |
538 | XD_DEBUG_VALID_LISP_OBJECT_P (args[i]); | |
539 | XD_DEBUG_MESSAGE ("Parameter%d %s", | |
540 | i-4, | |
541 | SDATA (format2 ("%s", args[i], Qnil))); | |
542 | ||
543 | dtype = XD_LISP_OBJECT_TO_DBUS_TYPE (args[i]); | |
544 | if (dtype == DBUS_TYPE_INVALID) | |
545 | xsignal2 (Qdbus_error, build_string ("Not a valid argument"), args[i]); | |
546 | ||
547 | value = (char *) xd_retrieve_value (dtype, args[i]); | |
548 | ||
549 | if (!dbus_message_append_args (dmessage, | |
550 | dtype, | |
551 | &value, | |
552 | DBUS_TYPE_INVALID)) | |
553 | xsignal2 (Qdbus_error, | |
554 | build_string ("Unable to append argument"), args[i]); | |
555 | } | |
556 | ||
557 | /* Send the message. The message is just added to the outgoing | |
558 | message queue. */ | |
559 | if (!dbus_connection_send (connection, dmessage, NULL)) | |
560 | xsignal1 (Qdbus_error, build_string ("Cannot send message")); | |
561 | ||
562 | /* Flush connection to ensure the message is handled. */ | |
563 | dbus_connection_flush (connection); | |
564 | ||
565 | XD_DEBUG_MESSAGE ("Signal sent"); | |
566 | ||
567 | /* Cleanup. */ | |
568 | dbus_message_unref (dmessage); | |
569 | ||
570 | /* Return. */ | |
571 | return Qt; | |
572 | } | |
573 | ||
574 | /* Read queued incoming message of the D-Bus BUS. BUS is a Lisp | |
575 | symbol, either :system or :session. */ | |
576 | void | |
577 | xd_read_message (bus) | |
578 | Lisp_Object bus; | |
579 | { | |
580 | Lisp_Object symbol; | |
581 | struct gcpro gcpro1; | |
582 | static struct input_event event; | |
583 | DBusConnection *connection; | |
584 | DBusMessage *dmessage; | |
585 | DBusMessageIter iter; | |
586 | uint dtype; | |
587 | char s1[1024], s2[1024]; | |
588 | ||
589 | /* Open a connection to the bus. */ | |
590 | connection = xd_initialize (bus); | |
591 | ||
592 | /* Non blocking read of the next available message. */ | |
593 | dbus_connection_read_write (connection, 0); | |
594 | dmessage = dbus_connection_pop_message (connection); | |
595 | ||
596 | /* Return if there is no queued message. */ | |
597 | if (dmessage == NULL) | |
598 | return; | |
599 | ||
600 | /* There is a message in the queue. Construct the D-Bus event. */ | |
601 | XD_DEBUG_MESSAGE ("Event received"); | |
602 | EVENT_INIT (event); | |
603 | ||
604 | event.kind = DBUS_EVENT; | |
605 | event.frame_or_window = Qnil; | |
606 | ||
607 | /* Collect the parameters. */ | |
608 | event.arg = Qnil; | |
609 | GCPRO1 (event.arg); | |
610 | ||
611 | if (!dbus_message_iter_init (dmessage, &iter)) | |
612 | { | |
613 | UNGCPRO; | |
614 | XD_DEBUG_MESSAGE ("Cannot read event"); | |
615 | return; | |
616 | } | |
617 | ||
618 | /* Loop over the resulting parameters. Construct a list. */ | |
619 | while ((dtype = dbus_message_iter_get_arg_type (&iter)) != DBUS_TYPE_INVALID) | |
620 | { | |
621 | event.arg = Fcons (xd_retrieve_arg (dtype, &iter), event.arg); | |
622 | dbus_message_iter_next (&iter); | |
623 | } | |
624 | ||
625 | /* The arguments are stored in reverse order. Reorder them. */ | |
626 | event.arg = Fnreverse (event.arg); | |
627 | ||
628 | /* Add the object path of the sender of the message. */ | |
629 | strcpy (s1, dbus_message_get_path (dmessage)); | |
630 | event.arg = Fcons ((s1 == NULL ? Qnil : build_string (s1)), event.arg); | |
631 | ||
632 | /* Add the unique name of the sender of the message. */ | |
633 | strcpy (s2, dbus_message_get_sender (dmessage)); | |
634 | event.arg = Fcons ((s2 == NULL ? Qnil : build_string (s2)), event.arg); | |
635 | ||
636 | /* Add the interned symbol the message is raised from (signal) or | |
637 | for (method). */ | |
638 | strcpy (s1, dbus_message_get_interface (dmessage)); | |
639 | strcpy (s2, dbus_message_get_member (dmessage)); | |
640 | XD_SYMBOL_INTERN_SYMBOL | |
641 | (symbol, bus, | |
642 | (s1 == NULL ? Qnil : build_string (s1)), | |
643 | (s2 == NULL ? Qnil : build_string (s2))); | |
644 | event.arg = Fcons (symbol, event.arg); | |
645 | ||
646 | /* Store it into the input event queue. */ | |
647 | kbd_buffer_store_event (&event); | |
648 | ||
649 | /* Cleanup. */ | |
650 | dbus_message_unref (dmessage); | |
651 | UNGCPRO; | |
652 | } | |
653 | ||
654 | /* Read queued incoming messages from the system and session buses. */ | |
655 | void | |
656 | xd_read_queued_messages () | |
657 | { | |
658 | xd_read_message (Qdbus_system_bus); | |
659 | xd_read_message (Qdbus_session_bus); | |
660 | } | |
661 | ||
662 | DEFUN ("dbus-register-signal", Fdbus_register_signal, Sdbus_register_signal, | |
663 | 6, 6, 0, | |
664 | doc: /* Register for signal SIGNAL on the D-Bus BUS. | |
665 | ||
666 | BUS is either the symbol `:system' or the symbol `:session'. | |
667 | ||
668 | SERVICE is the D-Bus service name to be used. PATH is the D-Bus | |
669 | object path SERVICE is registered. INTERFACE is an interface offered | |
670 | by SERVICE. It must provide SIGNAL. | |
671 | ||
672 | HANDLER is a Lisp function to be called when the signal is received. | |
673 | It must accept as arguments the values SIGNAL is sending. | |
674 | ||
675 | Example: | |
676 | ||
677 | \(defun my-signal-handler (device) | |
678 | (message "Device %s added" device)) | |
679 | ||
680 | \(dbus-register-signal | |
681 | :system "DeviceAdded" "org.freedesktop.Hal" | |
682 | "/org/freedesktop/Hal/Manager" "org.freedesktop.Hal.Manager" | |
683 | 'my-signal-handler) | |
684 | ||
685 | => org.freedesktop.Hal.Manager.DeviceAdded | |
686 | ||
687 | `dbus-register-signal' returns an object, which can be used in | |
688 | `dbus-unregister-signal' for removing the registration. */) | |
689 | (bus, signal, service, path, interface, handler) | |
690 | Lisp_Object bus, signal, service, path, interface, handler; | |
691 | { | |
692 | Lisp_Object name_owner, result; | |
693 | DBusConnection *connection; | |
694 | DBusError derror; | |
695 | char rule[1024]; | |
696 | ||
697 | /* Check parameters. */ | |
698 | CHECK_SYMBOL (bus); | |
699 | CHECK_STRING (signal); | |
700 | CHECK_STRING (service); | |
701 | CHECK_STRING (path); | |
702 | CHECK_STRING (interface); | |
703 | CHECK_SYMBOL (handler); | |
704 | ||
705 | /* Open a connection to the bus. */ | |
706 | connection = xd_initialize (bus); | |
707 | ||
708 | #if 0 | |
709 | /* TODO: Get name owner. This is the sending service name. */ | |
710 | name_owner = call2 (intern ("dbus-get-name-owner"), bus, service); | |
711 | #endif | |
712 | ||
713 | /* Add a rule to the bus in order to receive related signals. */ | |
714 | dbus_error_init (&derror); | |
715 | sprintf (rule, | |
716 | "type='signal',interface='%s',member=%s%", | |
717 | SDATA (interface), | |
718 | SDATA (signal)); | |
719 | #if 0 | |
720 | /* TODO: We need better checks when we want use sender and path. */ | |
721 | sprintf (rule, | |
722 | "type='signal',sender='%s',path='%s',interface='%s',member=%s%", | |
723 | SDATA (name_owner), | |
724 | SDATA (path), | |
725 | SDATA (interface), | |
726 | SDATA (signal)); | |
727 | #endif | |
728 | dbus_bus_add_match (connection, rule, &derror); | |
729 | ||
730 | if (dbus_error_is_set (&derror)) | |
731 | XD_ERROR (derror); | |
732 | ||
733 | XD_DEBUG_MESSAGE ("Matching rule \"%s\" created", rule); | |
734 | ||
735 | /* Create a new protected symbol, which has the complete name of the | |
736 | signal. The function cell is taken from the handler. */ | |
737 | result = Qnil; | |
738 | ||
739 | XD_SYMBOL_INTERN_SYMBOL (result, bus, interface, signal); | |
740 | Ffset (result, Fsymbol_function (handler)); | |
741 | XD_DEBUG_MESSAGE ("\"%s\" registered with handler \"%s\"", | |
742 | SDATA (format2 ("%s", result, Qnil)), | |
743 | SDATA (format2 ("%s", Fsymbol_function (result), Qnil))); | |
744 | ||
745 | /* Return. */ | |
746 | return result; | |
747 | } | |
748 | ||
749 | DEFUN ("dbus-unregister-signal", Fdbus_unregister_signal, Sdbus_unregister_signal, | |
750 | 1, 1, 0, | |
751 | doc: /* Unregister OBJECT from the D-Bus. | |
752 | OBJECT must be the result of a preceding `dbus-register-signal' call. */) | |
753 | (object) | |
754 | Lisp_Object object; | |
755 | { | |
756 | ||
757 | /* Check parameters. */ | |
758 | CHECK_SYMBOL (object); | |
759 | ||
760 | XD_DEBUG_MESSAGE ("\"%s\" unregistered with handler \"%s\"", | |
761 | SDATA (format2 ("%s", object, Qnil)), | |
762 | SDATA (format2 ("%s", Fsymbol_function (object), Qnil))); | |
763 | ||
764 | /* Unintern the signal symbol. */ | |
765 | Funintern (object, Vdbus_intern_symbols); | |
766 | ||
767 | /* Return. */ | |
768 | return Qnil; | |
769 | } | |
770 | ||
771 | \f | |
772 | void | |
773 | syms_of_dbusbind () | |
774 | { | |
775 | ||
776 | Qdbus_get_unique_name = intern ("dbus-get-unique-name"); | |
777 | staticpro (&Qdbus_get_unique_name); | |
778 | defsubr (&Sdbus_get_unique_name); | |
779 | ||
780 | Qdbus_call_method = intern ("dbus-call-method"); | |
781 | staticpro (&Qdbus_call_method); | |
782 | defsubr (&Sdbus_call_method); | |
783 | ||
784 | Qdbus_send_signal = intern ("dbus-send-signal"); | |
785 | staticpro (&Qdbus_send_signal); | |
786 | defsubr (&Sdbus_send_signal); | |
787 | ||
788 | Qdbus_register_signal = intern ("dbus-register-signal"); | |
789 | staticpro (&Qdbus_register_signal); | |
790 | defsubr (&Sdbus_register_signal); | |
791 | ||
792 | Qdbus_unregister_signal = intern ("dbus-unregister-signal"); | |
793 | staticpro (&Qdbus_unregister_signal); | |
794 | defsubr (&Sdbus_unregister_signal); | |
795 | ||
796 | Qdbus_error = intern ("dbus-error"); | |
797 | staticpro (&Qdbus_error); | |
798 | Fput (Qdbus_error, Qerror_conditions, | |
799 | list2 (Qdbus_error, Qerror)); | |
800 | Fput (Qdbus_error, Qerror_message, | |
801 | build_string ("D-Bus error")); | |
802 | ||
803 | Qdbus_system_bus = intern (":system"); | |
804 | staticpro (&Qdbus_system_bus); | |
805 | ||
806 | Qdbus_session_bus = intern (":session"); | |
807 | staticpro (&Qdbus_session_bus); | |
808 | ||
809 | Vdbus_intern_symbols = Fmake_vector (make_number (64), 0); | |
810 | staticpro (&Vdbus_intern_symbols); | |
811 | ||
812 | DEFVAR_LISP ("dbus-debug", &Vdbus_debug, | |
813 | doc: /* If non-nil, debug messages of D-Bus bindings are raised. */); | |
814 | #ifdef DBUS_DEBUG | |
815 | Vdbus_debug = Qt; | |
816 | #else | |
817 | Vdbus_debug = Qnil; | |
818 | #endif | |
819 | ||
820 | Fprovide (intern ("dbusbind"), Qnil); | |
821 | ||
822 | } | |
823 | ||
824 | #endif /* HAVE_DBUS */ |