HCoop / bpt / emacs.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
* dbusbind.c (QCdbus_type_unix_fd): New Lisp object.
[bpt/emacs.git] / src / dbusbind.c
1 /* Elisp bindings for D-Bus.
2 Copyright (C) 2007, 2008, 2009, 2010 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 of the License, or
9 (at your option) 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. If not, see <http://www.gnu.org/licenses/>. */
18
19 #include <config.h>
20
21 #ifdef HAVE_DBUS
22 #include <stdio.h>
23 #include <dbus/dbus.h>
24 #include <setjmp.h>
25 #include "lisp.h"
26 #include "frame.h"
27 #include "termhooks.h"
28 #include "keyboard.h"
29 #include "process.h"
30
31 \f
32 /* Subroutines. */
33 Lisp_Object Qdbus_init_bus;
34 Lisp_Object Qdbus_close_bus;
35 Lisp_Object Qdbus_get_unique_name;
36 Lisp_Object Qdbus_call_method;
37 Lisp_Object Qdbus_call_method_asynchronously;
38 Lisp_Object Qdbus_method_return_internal;
39 Lisp_Object Qdbus_method_error_internal;
40 Lisp_Object Qdbus_send_signal;
41 Lisp_Object Qdbus_register_signal;
42 Lisp_Object Qdbus_register_method;
43
44 /* D-Bus error symbol. */
45 Lisp_Object Qdbus_error;
46
47 /* Lisp symbols of the system and session buses. */
48 Lisp_Object QCdbus_system_bus, QCdbus_session_bus;
49
50 /* Lisp symbol for method call timeout. */
51 Lisp_Object QCdbus_timeout;
52
53 /* Lisp symbols of D-Bus types. */
54 Lisp_Object QCdbus_type_byte, QCdbus_type_boolean;
55 Lisp_Object QCdbus_type_int16, QCdbus_type_uint16;
56 Lisp_Object QCdbus_type_int32, QCdbus_type_uint32;
57 Lisp_Object QCdbus_type_int64, QCdbus_type_uint64;
58 Lisp_Object QCdbus_type_double, QCdbus_type_string;
59 Lisp_Object QCdbus_type_object_path, QCdbus_type_signature;
60 #ifdef DBUS_TYPE_UNIX_FD
61 Lisp_Object QCdbus_type_unix_fd;
62 #endif
63 Lisp_Object QCdbus_type_array, QCdbus_type_variant;
64 Lisp_Object QCdbus_type_struct, QCdbus_type_dict_entry;
65
66 /* Registered buses. */
67 Lisp_Object Vdbus_registered_buses;
68
69 /* Hash table which keeps function definitions. */
70 Lisp_Object Vdbus_registered_objects_table;
71
72 /* Whether to debug D-Bus. */
73 Lisp_Object Vdbus_debug;
74
75 /* Whether we are reading a D-Bus event. */
76 int xd_in_read_queued_messages = 0;
77
78 \f
79 /* We use "xd_" and "XD_" as prefix for all internal symbols, because
80 we don't want to poison other namespaces with "dbus_". */
81
82 /* Raise a signal. If we are reading events, we cannot signal; we
83 throw to xd_read_queued_messages then. */
84 #define XD_SIGNAL1(arg) \
85 do { \
86 if (xd_in_read_queued_messages) \
87 Fthrow (Qdbus_error, Qnil); \
88 else \
89 xsignal1 (Qdbus_error, arg); \
90 } while (0)
91
92 #define XD_SIGNAL2(arg1, arg2) \
93 do { \
94 if (xd_in_read_queued_messages) \
95 Fthrow (Qdbus_error, Qnil); \
96 else \
97 xsignal2 (Qdbus_error, arg1, arg2); \
98 } while (0)
99
100 #define XD_SIGNAL3(arg1, arg2, arg3) \
101 do { \
102 if (xd_in_read_queued_messages) \
103 Fthrow (Qdbus_error, Qnil); \
104 else \
105 xsignal3 (Qdbus_error, arg1, arg2, arg3); \
106 } while (0)
107
108 /* Raise a Lisp error from a D-Bus ERROR. */
109 #define XD_ERROR(error) \
110 do { \
111 char s[1024]; \
112 strncpy (s, error.message, 1023); \
113 dbus_error_free (&error); \
114 /* Remove the trailing newline. */ \
115 if (strchr (s, '\n') != NULL) \
116 s[strlen (s) - 1] = '\0'; \
117 XD_SIGNAL1 (build_string (s)); \
118 } while (0)
119
120 /* Macros for debugging. In order to enable them, build with
121 "MYCPPFLAGS='-DDBUS_DEBUG -Wall' make". */
122 #ifdef DBUS_DEBUG
123 #define XD_DEBUG_MESSAGE(...) \
124 do { \
125 char s[1024]; \
126 snprintf (s, 1023, __VA_ARGS__); \
127 printf ("%s: %s\n", __func__, s); \
128 message ("%s: %s", __func__, s); \
129 } while (0)
130 #define XD_DEBUG_VALID_LISP_OBJECT_P(object) \
131 do { \
132 if (!valid_lisp_object_p (object)) \
133 { \
134 XD_DEBUG_MESSAGE ("%d Assertion failure", __LINE__); \
135 XD_SIGNAL1 (build_string ("Assertion failure")); \
136 } \
137 } while (0)
138
139 #else /* !DBUS_DEBUG */
140 #define XD_DEBUG_MESSAGE(...) \
141 do { \
142 if (!NILP (Vdbus_debug)) \
143 { \
144 char s[1024]; \
145 snprintf (s, 1023, __VA_ARGS__); \
146 message ("%s: %s", __func__, s); \
147 } \
148 } while (0)
149 #define XD_DEBUG_VALID_LISP_OBJECT_P(object)
150 #endif
151
152 /* Check whether TYPE is a basic DBusType. */
153 #ifdef DBUS_TYPE_UNIX_FD
154 #define XD_BASIC_DBUS_TYPE(type) \
155 ((type == DBUS_TYPE_BYTE) \
156 || (type == DBUS_TYPE_BOOLEAN) \
157 || (type == DBUS_TYPE_INT16) \
158 || (type == DBUS_TYPE_UINT16) \
159 || (type == DBUS_TYPE_INT32) \
160 || (type == DBUS_TYPE_UINT32) \
161 || (type == DBUS_TYPE_INT64) \
162 || (type == DBUS_TYPE_UINT64) \
163 || (type == DBUS_TYPE_DOUBLE) \
164 || (type == DBUS_TYPE_STRING) \
165 || (type == DBUS_TYPE_OBJECT_PATH) \
166 || (type == DBUS_TYPE_SIGNATURE \
167 || (type == DBUS_TYPE_UNIX_FD))
168 #else
169 #define XD_BASIC_DBUS_TYPE(type) \
170 ((type == DBUS_TYPE_BYTE) \
171 || (type == DBUS_TYPE_BOOLEAN) \
172 || (type == DBUS_TYPE_INT16) \
173 || (type == DBUS_TYPE_UINT16) \
174 || (type == DBUS_TYPE_INT32) \
175 || (type == DBUS_TYPE_UINT32) \
176 || (type == DBUS_TYPE_INT64) \
177 || (type == DBUS_TYPE_UINT64) \
178 || (type == DBUS_TYPE_DOUBLE) \
179 || (type == DBUS_TYPE_STRING) \
180 || (type == DBUS_TYPE_OBJECT_PATH) \
181 || (type == DBUS_TYPE_SIGNATURE))
182 #endif
183
184 /* This was a macro. On Solaris 2.11 it was said to compile for
185 hours, when optimzation is enabled. So we have transferred it into
186 a function. */
187 /* Determine the DBusType of a given Lisp symbol. OBJECT must be one
188 of the predefined D-Bus type symbols. */
189 static int
190 xd_symbol_to_dbus_type (Lisp_Object object)
191 {
192 return
193 ((EQ (object, QCdbus_type_byte)) ? DBUS_TYPE_BYTE
194 : (EQ (object, QCdbus_type_boolean)) ? DBUS_TYPE_BOOLEAN
195 : (EQ (object, QCdbus_type_int16)) ? DBUS_TYPE_INT16
196 : (EQ (object, QCdbus_type_uint16)) ? DBUS_TYPE_UINT16
197 : (EQ (object, QCdbus_type_int32)) ? DBUS_TYPE_INT32
198 : (EQ (object, QCdbus_type_uint32)) ? DBUS_TYPE_UINT32
199 : (EQ (object, QCdbus_type_int64)) ? DBUS_TYPE_INT64
200 : (EQ (object, QCdbus_type_uint64)) ? DBUS_TYPE_UINT64
201 : (EQ (object, QCdbus_type_double)) ? DBUS_TYPE_DOUBLE
202 : (EQ (object, QCdbus_type_string)) ? DBUS_TYPE_STRING
203 : (EQ (object, QCdbus_type_object_path)) ? DBUS_TYPE_OBJECT_PATH
204 : (EQ (object, QCdbus_type_signature)) ? DBUS_TYPE_SIGNATURE
205 #ifdef DBUS_TYPE_UNIX_FD
206 : (EQ (object, QCdbus_type_unix_fd)) ? DBUS_TYPE_UNIX_FD
207 #endif
208 : (EQ (object, QCdbus_type_array)) ? DBUS_TYPE_ARRAY
209 : (EQ (object, QCdbus_type_variant)) ? DBUS_TYPE_VARIANT
210 : (EQ (object, QCdbus_type_struct)) ? DBUS_TYPE_STRUCT
211 : (EQ (object, QCdbus_type_dict_entry)) ? DBUS_TYPE_DICT_ENTRY
212 : DBUS_TYPE_INVALID);
213 }
214
215 /* Check whether a Lisp symbol is a predefined D-Bus type symbol. */
216 #define XD_DBUS_TYPE_P(object) \
217 (SYMBOLP (object) && ((xd_symbol_to_dbus_type (object) != DBUS_TYPE_INVALID)))
218
219 /* Determine the DBusType of a given Lisp OBJECT. It is used to
220 convert Lisp objects, being arguments of `dbus-call-method' or
221 `dbus-send-signal', into corresponding C values appended as
222 arguments to a D-Bus message. */
223 #define XD_OBJECT_TO_DBUS_TYPE(object) \
224 ((EQ (object, Qt) || EQ (object, Qnil)) ? DBUS_TYPE_BOOLEAN \
225 : (NATNUMP (object)) ? DBUS_TYPE_UINT32 \
226 : (INTEGERP (object)) ? DBUS_TYPE_INT32 \
227 : (FLOATP (object)) ? DBUS_TYPE_DOUBLE \
228 : (STRINGP (object)) ? DBUS_TYPE_STRING \
229 : (XD_DBUS_TYPE_P (object)) ? xd_symbol_to_dbus_type (object) \
230 : (CONSP (object)) \
231 ? ((XD_DBUS_TYPE_P (CAR_SAFE (object))) \
232 ? ((XD_BASIC_DBUS_TYPE (xd_symbol_to_dbus_type (CAR_SAFE (object)))) \
233 ? DBUS_TYPE_ARRAY \
234 : xd_symbol_to_dbus_type (CAR_SAFE (object))) \
235 : DBUS_TYPE_ARRAY) \
236 : DBUS_TYPE_INVALID)
237
238 /* Return a list pointer which does not have a Lisp symbol as car. */
239 #define XD_NEXT_VALUE(object) \
240 ((XD_DBUS_TYPE_P (CAR_SAFE (object))) ? CDR_SAFE (object) : object)
241
242 /* Compute SIGNATURE of OBJECT. It must have a form that it can be
243 used in dbus_message_iter_open_container. DTYPE is the DBusType
244 the object is related to. It is passed as argument, because it
245 cannot be detected in basic type objects, when they are preceded by
246 a type symbol. PARENT_TYPE is the DBusType of a container this
247 signature is embedded, or DBUS_TYPE_INVALID. It is needed for the
248 check that DBUS_TYPE_DICT_ENTRY occurs only as array element. */
249 static void
250 xd_signature (char *signature, unsigned int dtype, unsigned int parent_type, Lisp_Object object)
251 {
252 unsigned int subtype;
253 Lisp_Object elt;
254 char x[DBUS_MAXIMUM_SIGNATURE_LENGTH];
255
256 elt = object;
257
258 switch (dtype)
259 {
260 case DBUS_TYPE_BYTE:
261 case DBUS_TYPE_UINT16:
262 case DBUS_TYPE_UINT32:
263 case DBUS_TYPE_UINT64:
264 #ifdef DBUS_TYPE_UNIX_FD
265 case DBUS_TYPE_UNIX_FD:
266 #endif
267 CHECK_NATNUM (object);
268 sprintf (signature, "%c", dtype);
269 break;
270
271 case DBUS_TYPE_BOOLEAN:
272 if (!EQ (object, Qt) && !EQ (object, Qnil))
273 wrong_type_argument (intern ("booleanp"), object);
274 sprintf (signature, "%c", dtype);
275 break;
276
277 case DBUS_TYPE_INT16:
278 case DBUS_TYPE_INT32:
279 case DBUS_TYPE_INT64:
280 CHECK_NUMBER (object);
281 sprintf (signature, "%c", dtype);
282 break;
283
284 case DBUS_TYPE_DOUBLE:
285 CHECK_FLOAT (object);
286 sprintf (signature, "%c", dtype);
287 break;
288
289 case DBUS_TYPE_STRING:
290 case DBUS_TYPE_OBJECT_PATH:
291 case DBUS_TYPE_SIGNATURE:
292 CHECK_STRING (object);
293 sprintf (signature, "%c", dtype);
294 break;
295
296 case DBUS_TYPE_ARRAY:
297 /* Check that all list elements have the same D-Bus type. For
298 complex element types, we just check the container type, not
299 the whole element's signature. */
300 CHECK_CONS (object);
301
302 /* Type symbol is optional. */
303 if (EQ (QCdbus_type_array, CAR_SAFE (elt)))
304 elt = XD_NEXT_VALUE (elt);
305
306 /* If the array is empty, DBUS_TYPE_STRING is the default
307 element type. */
308 if (NILP (elt))
309 {
310 subtype = DBUS_TYPE_STRING;
311 strcpy (x, DBUS_TYPE_STRING_AS_STRING);
312 }
313 else
314 {
315 subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
316 xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
317 }
318
319 /* If the element type is DBUS_TYPE_SIGNATURE, and this is the
320 only element, the value of this element is used as he array's
321 element signature. */
322 if ((subtype == DBUS_TYPE_SIGNATURE)
323 && STRINGP (CAR_SAFE (XD_NEXT_VALUE (elt)))
324 && NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
325 strcpy (x, SDATA (CAR_SAFE (XD_NEXT_VALUE (elt))));
326
327 while (!NILP (elt))
328 {
329 if (subtype != XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt)))
330 wrong_type_argument (intern ("D-Bus"), CAR_SAFE (elt));
331 elt = CDR_SAFE (XD_NEXT_VALUE (elt));
332 }
333
334 sprintf (signature, "%c%s", dtype, x);
335 break;
336
337 case DBUS_TYPE_VARIANT:
338 /* Check that there is exactly one list element. */
339 CHECK_CONS (object);
340
341 elt = XD_NEXT_VALUE (elt);
342 subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
343 xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
344
345 if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
346 wrong_type_argument (intern ("D-Bus"),
347 CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt))));
348
349 sprintf (signature, "%c", dtype);
350 break;
351
352 case DBUS_TYPE_STRUCT:
353 /* A struct list might contain any number of elements with
354 different types. No further check needed. */
355 CHECK_CONS (object);
356
357 elt = XD_NEXT_VALUE (elt);
358
359 /* Compose the signature from the elements. It is enclosed by
360 parentheses. */
361 sprintf (signature, "%c", DBUS_STRUCT_BEGIN_CHAR );
362 while (!NILP (elt))
363 {
364 subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
365 xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
366 strcat (signature, x);
367 elt = CDR_SAFE (XD_NEXT_VALUE (elt));
368 }
369 strcat (signature, DBUS_STRUCT_END_CHAR_AS_STRING);
370 break;
371
372 case DBUS_TYPE_DICT_ENTRY:
373 /* Check that there are exactly two list elements, and the first
374 one is of basic type. The dictionary entry itself must be an
375 element of an array. */
376 CHECK_CONS (object);
377
378 /* Check the parent object type. */
379 if (parent_type != DBUS_TYPE_ARRAY)
380 wrong_type_argument (intern ("D-Bus"), object);
381
382 /* Compose the signature from the elements. It is enclosed by
383 curly braces. */
384 sprintf (signature, "%c", DBUS_DICT_ENTRY_BEGIN_CHAR);
385
386 /* First element. */
387 elt = XD_NEXT_VALUE (elt);
388 subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
389 xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
390 strcat (signature, x);
391
392 if (!XD_BASIC_DBUS_TYPE (subtype))
393 wrong_type_argument (intern ("D-Bus"), CAR_SAFE (XD_NEXT_VALUE (elt)));
394
395 /* Second element. */
396 elt = CDR_SAFE (XD_NEXT_VALUE (elt));
397 subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
398 xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
399 strcat (signature, x);
400
401 if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
402 wrong_type_argument (intern ("D-Bus"),
403 CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt))));
404
405 /* Closing signature. */
406 strcat (signature, DBUS_DICT_ENTRY_END_CHAR_AS_STRING);
407 break;
408
409 default:
410 wrong_type_argument (intern ("D-Bus"), object);
411 }
412
413 XD_DEBUG_MESSAGE ("%s", signature);
414 }
415
416 /* Append C value, extracted from Lisp OBJECT, to iteration ITER.
417 DTYPE must be a valid DBusType. It is used to convert Lisp
418 objects, being arguments of `dbus-call-method' or
419 `dbus-send-signal', into corresponding C values appended as
420 arguments to a D-Bus message. */
421 static void
422 xd_append_arg (unsigned int dtype, Lisp_Object object, DBusMessageIter *iter)
423 {
424 char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
425 DBusMessageIter subiter;
426
427 if (XD_BASIC_DBUS_TYPE (dtype))
428 switch (dtype)
429 {
430 case DBUS_TYPE_BYTE:
431 CHECK_NUMBER (object);
432 {
433 unsigned char val = XUINT (object) & 0xFF;
434 XD_DEBUG_MESSAGE ("%c %d", dtype, val);
435 if (!dbus_message_iter_append_basic (iter, dtype, &val))
436 XD_SIGNAL2 (build_string ("Unable to append argument"), object);
437 return;
438 }
439
440 case DBUS_TYPE_BOOLEAN:
441 {
442 dbus_bool_t val = (NILP (object)) ? FALSE : TRUE;
443 XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true");
444 if (!dbus_message_iter_append_basic (iter, dtype, &val))
445 XD_SIGNAL2 (build_string ("Unable to append argument"), object);
446 return;
447 }
448
449 case DBUS_TYPE_INT16:
450 CHECK_NUMBER (object);
451 {
452 dbus_int16_t val = XINT (object);
453 XD_DEBUG_MESSAGE ("%c %d", dtype, (int) val);
454 if (!dbus_message_iter_append_basic (iter, dtype, &val))
455 XD_SIGNAL2 (build_string ("Unable to append argument"), object);
456 return;
457 }
458
459 case DBUS_TYPE_UINT16:
460 CHECK_NUMBER (object);
461 {
462 dbus_uint16_t val = XUINT (object);
463 XD_DEBUG_MESSAGE ("%c %u", dtype, (unsigned int) val);
464 if (!dbus_message_iter_append_basic (iter, dtype, &val))
465 XD_SIGNAL2 (build_string ("Unable to append argument"), object);
466 return;
467 }
468
469 case DBUS_TYPE_INT32:
470 CHECK_NUMBER (object);
471 {
472 dbus_int32_t val = XINT (object);
473 XD_DEBUG_MESSAGE ("%c %d", dtype, val);
474 if (!dbus_message_iter_append_basic (iter, dtype, &val))
475 XD_SIGNAL2 (build_string ("Unable to append argument"), object);
476 return;
477 }
478
479 case DBUS_TYPE_UINT32:
480 #ifdef DBUS_TYPE_UNIX_FD
481 case DBUS_TYPE_UNIX_FD:
482 #endif
483 CHECK_NUMBER (object);
484 {
485 dbus_uint32_t val = XUINT (object);
486 XD_DEBUG_MESSAGE ("%c %u", dtype, val);
487 if (!dbus_message_iter_append_basic (iter, dtype, &val))
488 XD_SIGNAL2 (build_string ("Unable to append argument"), object);
489 return;
490 }
491
492 case DBUS_TYPE_INT64:
493 CHECK_NUMBER (object);
494 {
495 dbus_int64_t val = XINT (object);
496 XD_DEBUG_MESSAGE ("%c %d", dtype, (int) val);
497 if (!dbus_message_iter_append_basic (iter, dtype, &val))
498 XD_SIGNAL2 (build_string ("Unable to append argument"), object);
499 return;
500 }
501
502 case DBUS_TYPE_UINT64:
503 CHECK_NUMBER (object);
504 {
505 dbus_uint64_t val = XUINT (object);
506 XD_DEBUG_MESSAGE ("%c %u", dtype, (unsigned int) val);
507 if (!dbus_message_iter_append_basic (iter, dtype, &val))
508 XD_SIGNAL2 (build_string ("Unable to append argument"), object);
509 return;
510 }
511
512 case DBUS_TYPE_DOUBLE:
513 CHECK_FLOAT (object);
514 {
515 double val = XFLOAT_DATA (object);
516 XD_DEBUG_MESSAGE ("%c %f", dtype, val);
517 if (!dbus_message_iter_append_basic (iter, dtype, &val))
518 XD_SIGNAL2 (build_string ("Unable to append argument"), object);
519 return;
520 }
521
522 case DBUS_TYPE_STRING:
523 case DBUS_TYPE_OBJECT_PATH:
524 case DBUS_TYPE_SIGNATURE:
525 CHECK_STRING (object);
526 {
527 /* We need to send a valid UTF-8 string. We could encode `object'
528 but by not encoding it, we guarantee it's valid utf-8, even if
529 it contains eight-bit-bytes. Of course, you can still send
530 manually-crafted junk by passing a unibyte string. */
531 char *val = SDATA (object);
532 XD_DEBUG_MESSAGE ("%c %s", dtype, val);
533 if (!dbus_message_iter_append_basic (iter, dtype, &val))
534 XD_SIGNAL2 (build_string ("Unable to append argument"), object);
535 return;
536 }
537 }
538
539 else /* Compound types. */
540 {
541
542 /* All compound types except array have a type symbol. For
543 array, it is optional. Skip it. */
544 if (!XD_BASIC_DBUS_TYPE (XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object))))
545 object = XD_NEXT_VALUE (object);
546
547 /* Open new subiteration. */
548 switch (dtype)
549 {
550 case DBUS_TYPE_ARRAY:
551 /* An array has only elements of the same type. So it is
552 sufficient to check the first element's signature
553 only. */
554
555 if (NILP (object))
556 /* If the array is empty, DBUS_TYPE_STRING is the default
557 element type. */
558 strcpy (signature, DBUS_TYPE_STRING_AS_STRING);
559
560 else
561 /* If the element type is DBUS_TYPE_SIGNATURE, and this is
562 the only element, the value of this element is used as
563 the array's element signature. */
564 if ((XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object))
565 == DBUS_TYPE_SIGNATURE)
566 && STRINGP (CAR_SAFE (XD_NEXT_VALUE (object)))
567 && NILP (CDR_SAFE (XD_NEXT_VALUE (object))))
568 {
569 strcpy (signature, SDATA (CAR_SAFE (XD_NEXT_VALUE (object))));
570 object = CDR_SAFE (XD_NEXT_VALUE (object));
571 }
572
573 else
574 xd_signature (signature,
575 XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object)),
576 dtype, CAR_SAFE (XD_NEXT_VALUE (object)));
577
578 XD_DEBUG_MESSAGE ("%c %s %s", dtype, signature,
579 SDATA (format2 ("%s", object, Qnil)));
580 if (!dbus_message_iter_open_container (iter, dtype,
581 signature, &subiter))
582 XD_SIGNAL3 (build_string ("Cannot open container"),
583 make_number (dtype), build_string (signature));
584 break;
585
586 case DBUS_TYPE_VARIANT:
587 /* A variant has just one element. */
588 xd_signature (signature, XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object)),
589 dtype, CAR_SAFE (XD_NEXT_VALUE (object)));
590
591 XD_DEBUG_MESSAGE ("%c %s %s", dtype, signature,
592 SDATA (format2 ("%s", object, Qnil)));
593 if (!dbus_message_iter_open_container (iter, dtype,
594 signature, &subiter))
595 XD_SIGNAL3 (build_string ("Cannot open container"),
596 make_number (dtype), build_string (signature));
597 break;
598
599 case DBUS_TYPE_STRUCT:
600 case DBUS_TYPE_DICT_ENTRY:
601 /* These containers do not require a signature. */
602 XD_DEBUG_MESSAGE ("%c %s", dtype,
603 SDATA (format2 ("%s", object, Qnil)));
604 if (!dbus_message_iter_open_container (iter, dtype, NULL, &subiter))
605 XD_SIGNAL2 (build_string ("Cannot open container"),
606 make_number (dtype));
607 break;
608 }
609
610 /* Loop over list elements. */
611 while (!NILP (object))
612 {
613 dtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object));
614 object = XD_NEXT_VALUE (object);
615
616 xd_append_arg (dtype, CAR_SAFE (object), &subiter);
617
618 object = CDR_SAFE (object);
619 }
620
621 /* Close the subiteration. */
622 if (!dbus_message_iter_close_container (iter, &subiter))
623 XD_SIGNAL2 (build_string ("Cannot close container"),
624 make_number (dtype));
625 }
626 }
627
628 /* Retrieve C value from a DBusMessageIter structure ITER, and return
629 a converted Lisp object. The type DTYPE of the argument of the
630 D-Bus message must be a valid DBusType. Compound D-Bus types
631 result always in a Lisp list. */
632 static Lisp_Object
633 xd_retrieve_arg (unsigned int dtype, DBusMessageIter *iter)
634 {
635
636 switch (dtype)
637 {
638 case DBUS_TYPE_BYTE:
639 {
640 unsigned int val;
641 dbus_message_iter_get_basic (iter, &val);
642 val = val & 0xFF;
643 XD_DEBUG_MESSAGE ("%c %d", dtype, val);
644 return make_number (val);
645 }
646
647 case DBUS_TYPE_BOOLEAN:
648 {
649 dbus_bool_t val;
650 dbus_message_iter_get_basic (iter, &val);
651 XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true");
652 return (val == FALSE) ? Qnil : Qt;
653 }
654
655 case DBUS_TYPE_INT16:
656 {
657 dbus_int16_t val;
658 dbus_message_iter_get_basic (iter, &val);
659 XD_DEBUG_MESSAGE ("%c %d", dtype, val);
660 return make_number (val);
661 }
662
663 case DBUS_TYPE_UINT16:
664 {
665 dbus_uint16_t val;
666 dbus_message_iter_get_basic (iter, &val);
667 XD_DEBUG_MESSAGE ("%c %d", dtype, val);
668 return make_number (val);
669 }
670
671 case DBUS_TYPE_INT32:
672 {
673 dbus_int32_t val;
674 dbus_message_iter_get_basic (iter, &val);
675 XD_DEBUG_MESSAGE ("%c %d", dtype, val);
676 return make_fixnum_or_float (val);
677 }
678
679 case DBUS_TYPE_UINT32:
680 #ifdef DBUS_TYPE_UNIX_FD
681 case DBUS_TYPE_UNIX_FD:
682 #endif
683 {
684 dbus_uint32_t val;
685 dbus_message_iter_get_basic (iter, &val);
686 XD_DEBUG_MESSAGE ("%c %d", dtype, val);
687 return make_fixnum_or_float (val);
688 }
689
690 case DBUS_TYPE_INT64:
691 {
692 dbus_int64_t val;
693 dbus_message_iter_get_basic (iter, &val);
694 XD_DEBUG_MESSAGE ("%c %d", dtype, (int) val);
695 return make_fixnum_or_float (val);
696 }
697
698 case DBUS_TYPE_UINT64:
699 {
700 dbus_uint64_t val;
701 dbus_message_iter_get_basic (iter, &val);
702 XD_DEBUG_MESSAGE ("%c %d", dtype, (int) val);
703 return make_fixnum_or_float (val);
704 }
705
706 case DBUS_TYPE_DOUBLE:
707 {
708 double val;
709 dbus_message_iter_get_basic (iter, &val);
710 XD_DEBUG_MESSAGE ("%c %f", dtype, val);
711 return make_float (val);
712 }
713
714 case DBUS_TYPE_STRING:
715 case DBUS_TYPE_OBJECT_PATH:
716 case DBUS_TYPE_SIGNATURE:
717 {
718 char *val;
719 dbus_message_iter_get_basic (iter, &val);
720 XD_DEBUG_MESSAGE ("%c %s", dtype, val);
721 return build_string (val);
722 }
723
724 case DBUS_TYPE_ARRAY:
725 case DBUS_TYPE_VARIANT:
726 case DBUS_TYPE_STRUCT:
727 case DBUS_TYPE_DICT_ENTRY:
728 {
729 Lisp_Object result;
730 struct gcpro gcpro1;
731 DBusMessageIter subiter;
732 int subtype;
733 result = Qnil;
734 GCPRO1 (result);
735 dbus_message_iter_recurse (iter, &subiter);
736 while ((subtype = dbus_message_iter_get_arg_type (&subiter))
737 != DBUS_TYPE_INVALID)
738 {
739 result = Fcons (xd_retrieve_arg (subtype, &subiter), result);
740 dbus_message_iter_next (&subiter);
741 }
742 XD_DEBUG_MESSAGE ("%c %s", dtype, SDATA (format2 ("%s", result, Qnil)));
743 RETURN_UNGCPRO (Fnreverse (result));
744 }
745
746 default:
747 XD_DEBUG_MESSAGE ("DBusType '%c' not supported", dtype);
748 return Qnil;
749 }
750 }
751
752 /* Initialize D-Bus connection. BUS is either a Lisp symbol, :system
753 or :session, or a string denoting the bus address. It tells which
754 D-Bus to initialize. If RAISE_ERROR is non-zero, signal an error
755 when the connection cannot be initialized. */
756 static DBusConnection *
757 xd_initialize (Lisp_Object bus, int raise_error)
758 {
759 DBusConnection *connection;
760 DBusError derror;
761
762 /* Parameter check. */
763 if (!STRINGP (bus))
764 {
765 CHECK_SYMBOL (bus);
766 if (!(EQ (bus, QCdbus_system_bus) || EQ (bus, QCdbus_session_bus)))
767 {
768 if (raise_error)
769 XD_SIGNAL2 (build_string ("Wrong bus name"), bus);
770 else
771 return NULL;
772 }
773
774 /* We do not want to have an autolaunch for the session bus. */
775 if (EQ (bus, QCdbus_session_bus)
776 && getenv ("DBUS_SESSION_BUS_ADDRESS") == NULL)
777 {
778 if (raise_error)
779 XD_SIGNAL2 (build_string ("No connection to bus"), bus);
780 else
781 return NULL;
782 }
783 }
784
785 /* Open a connection to the bus. */
786 dbus_error_init (&derror);
787
788 if (STRINGP (bus))
789 connection = dbus_connection_open (SDATA (bus), &derror);
790 else
791 if (EQ (bus, QCdbus_system_bus))
792 connection = dbus_bus_get (DBUS_BUS_SYSTEM, &derror);
793 else
794 connection = dbus_bus_get (DBUS_BUS_SESSION, &derror);
795
796 if (dbus_error_is_set (&derror))
797 {
798 if (raise_error)
799 XD_ERROR (derror);
800 else
801 connection = NULL;
802 }
803
804 /* If it is not the system or session bus, we must register
805 ourselves. Otherwise, we have called dbus_bus_get, which has
806 configured us to exit if the connection closes - we undo this
807 setting. */
808 if (connection != NULL)
809 {
810 if (STRINGP (bus))
811 dbus_bus_register (connection, &derror);
812 else
813 dbus_connection_set_exit_on_disconnect (connection, FALSE);
814 }
815
816 if (dbus_error_is_set (&derror))
817 {
818 if (raise_error)
819 XD_ERROR (derror);
820 else
821 connection = NULL;
822 }
823
824 if (connection == NULL && raise_error)
825 XD_SIGNAL2 (build_string ("No connection to bus"), bus);
826
827 /* Cleanup. */
828 dbus_error_free (&derror);
829
830 /* Return the result. */
831 return connection;
832 }
833
834 /* Return the file descriptor for WATCH, -1 if not found. */
835 static int
836 xd_find_watch_fd (DBusWatch *watch)
837 {
838 #if HAVE_DBUS_WATCH_GET_UNIX_FD
839 /* TODO: Reverse these on Win32, which prefers the opposite. */
840 int fd = dbus_watch_get_unix_fd (watch);
841 if (fd == -1)
842 fd = dbus_watch_get_socket (watch);
843 #else
844 int fd = dbus_watch_get_fd (watch);
845 #endif
846 return fd;
847 }
848
849 /* Prototype. */
850 static void
851 xd_read_queued_messages (int fd, void *data, int for_read);
852
853 /* Start monitoring WATCH for possible I/O. */
854 static dbus_bool_t
855 xd_add_watch (DBusWatch *watch, void *data)
856 {
857 unsigned int flags = dbus_watch_get_flags (watch);
858 int fd = xd_find_watch_fd (watch);
859
860 XD_DEBUG_MESSAGE ("fd %d, write %d, enabled %d",
861 fd, flags & DBUS_WATCH_WRITABLE,
862 dbus_watch_get_enabled (watch));
863
864 if (fd == -1)
865 return FALSE;
866
867 if (dbus_watch_get_enabled (watch))
868 {
869 if (flags & DBUS_WATCH_WRITABLE)
870 add_write_fd (fd, xd_read_queued_messages, data);
871 if (flags & DBUS_WATCH_READABLE)
872 add_read_fd (fd, xd_read_queued_messages, data);
873 }
874 return TRUE;
875 }
876
877 /* Stop monitoring WATCH for possible I/O.
878 DATA is the used bus, either a string or QCdbus_system_bus or
879 QCdbus_session_bus. */
880 static void
881 xd_remove_watch (DBusWatch *watch, void *data)
882 {
883 unsigned int flags = dbus_watch_get_flags (watch);
884 int fd = xd_find_watch_fd (watch);
885
886 XD_DEBUG_MESSAGE ("fd %d", fd);
887
888 if (fd == -1)
889 return;
890
891 /* Unset session environment. */
892 if (data != NULL && data == (void*) XHASH (QCdbus_session_bus))
893 {
894 XD_DEBUG_MESSAGE ("unsetenv DBUS_SESSION_BUS_ADDRESS");
895 unsetenv ("DBUS_SESSION_BUS_ADDRESS");
896 }
897
898 if (flags & DBUS_WATCH_WRITABLE)
899 delete_write_fd (fd);
900 if (flags & DBUS_WATCH_READABLE)
901 delete_read_fd (fd);
902 }
903
904 /* Toggle monitoring WATCH for possible I/O. */
905 static void
906 xd_toggle_watch (DBusWatch *watch, void *data)
907 {
908 if (dbus_watch_get_enabled (watch))
909 xd_add_watch (watch, data);
910 else
911 xd_remove_watch (watch, data);
912 }
913
914 DEFUN ("dbus-init-bus", Fdbus_init_bus, Sdbus_init_bus, 1, 1, 0,
915 doc: /* Initialize connection to D-Bus BUS. */)
916 (Lisp_Object bus)
917 {
918 DBusConnection *connection;
919
920 /* Open a connection to the bus. */
921 connection = xd_initialize (bus, TRUE);
922
923 /* Add the watch functions. We pass also the bus as data, in order
924 to distinguish between the busses in xd_remove_watch. */
925 if (!dbus_connection_set_watch_functions (connection,
926 xd_add_watch,
927 xd_remove_watch,
928 xd_toggle_watch,
929 (void*) XHASH (bus), NULL))
930 XD_SIGNAL1 (build_string ("Cannot add watch functions"));
931
932 /* Add bus to list of registered buses. */
933 Vdbus_registered_buses = Fcons (bus, Vdbus_registered_buses);
934
935 /* We do not want to abort. */
936 putenv ("DBUS_FATAL_WARNINGS=0");
937
938 /* Return. */
939 return Qnil;
940 }
941
942 DEFUN ("dbus-close-bus", Fdbus_close_bus, Sdbus_close_bus, 1, 1, 0,
943 doc: /* Close connection to D-Bus BUS. */)
944 (Lisp_Object bus)
945 {
946 DBusConnection *connection;
947
948 /* Open a connection to the bus. */
949 connection = xd_initialize (bus, TRUE);
950
951 /* Decrement reference count to the bus. */
952 dbus_connection_unref (connection);
953
954 /* Remove bus from list of registered buses. */
955 Vdbus_registered_buses = Fdelete (bus, Vdbus_registered_buses);
956
957 /* Return. */
958 return Qnil;
959 }
960
961 DEFUN ("dbus-get-unique-name", Fdbus_get_unique_name, Sdbus_get_unique_name,
962 1, 1, 0,
963 doc: /* Return the unique name of Emacs registered at D-Bus BUS. */)
964 (Lisp_Object bus)
965 {
966 DBusConnection *connection;
967 const char *name;
968
969 /* Open a connection to the bus. */
970 connection = xd_initialize (bus, TRUE);
971
972 /* Request the name. */
973 name = dbus_bus_get_unique_name (connection);
974 if (name == NULL)
975 XD_SIGNAL1 (build_string ("No unique name available"));
976
977 /* Return. */
978 return build_string (name);
979 }
980
981 DEFUN ("dbus-call-method", Fdbus_call_method, Sdbus_call_method, 5, MANY, 0,
982 doc: /* Call METHOD on the D-Bus BUS.
983
984 BUS is either a Lisp symbol, `:system' or `:session', or a string
985 denoting the bus address.
986
987 SERVICE is the D-Bus service name to be used. PATH is the D-Bus
988 object path SERVICE is registered at. INTERFACE is an interface
989 offered by SERVICE. It must provide METHOD.
990
991 If the parameter `:timeout' is given, the following integer TIMEOUT
992 specifies the maximum number of milliseconds the method call must
993 return. The default value is 25,000. If the method call doesn't
994 return in time, a D-Bus error is raised.
995
996 All other arguments ARGS are passed to METHOD as arguments. They are
997 converted into D-Bus types via the following rules:
998
999 t and nil => DBUS_TYPE_BOOLEAN
1000 number => DBUS_TYPE_UINT32
1001 integer => DBUS_TYPE_INT32
1002 float => DBUS_TYPE_DOUBLE
1003 string => DBUS_TYPE_STRING
1004 list => DBUS_TYPE_ARRAY
1005
1006 All arguments can be preceded by a type symbol. For details about
1007 type symbols, see Info node `(dbus)Type Conversion'.
1008
1009 `dbus-call-method' returns the resulting values of METHOD as a list of
1010 Lisp objects. The type conversion happens the other direction as for
1011 input arguments. It follows the mapping rules:
1012
1013 DBUS_TYPE_BOOLEAN => t or nil
1014 DBUS_TYPE_BYTE => number
1015 DBUS_TYPE_UINT16 => number
1016 DBUS_TYPE_INT16 => integer
1017 DBUS_TYPE_UINT32 => number or float
1018 DBUS_TYPE_UNIX_FD => number or float
1019 DBUS_TYPE_INT32 => integer or float
1020 DBUS_TYPE_UINT64 => number or float
1021 DBUS_TYPE_INT64 => integer or float
1022 DBUS_TYPE_DOUBLE => float
1023 DBUS_TYPE_STRING => string
1024 DBUS_TYPE_OBJECT_PATH => string
1025 DBUS_TYPE_SIGNATURE => string
1026 DBUS_TYPE_ARRAY => list
1027 DBUS_TYPE_VARIANT => list
1028 DBUS_TYPE_STRUCT => list
1029 DBUS_TYPE_DICT_ENTRY => list
1030
1031 Example:
1032
1033 \(dbus-call-method
1034 :session "org.gnome.seahorse" "/org/gnome/seahorse/keys/openpgp"
1035 "org.gnome.seahorse.Keys" "GetKeyField"
1036 "openpgp:657984B8C7A966DD" "simple-name")
1037
1038 => (t ("Philip R. Zimmermann"))
1039
1040 If the result of the METHOD call is just one value, the converted Lisp
1041 object is returned instead of a list containing this single Lisp object.
1042
1043 \(dbus-call-method
1044 :system "org.freedesktop.Hal" "/org/freedesktop/Hal/devices/computer"
1045 "org.freedesktop.Hal.Device" "GetPropertyString"
1046 "system.kernel.machine")
1047
1048 => "i686"
1049
1050 usage: (dbus-call-method BUS SERVICE PATH INTERFACE METHOD &optional :timeout TIMEOUT &rest ARGS) */)
1051 (int nargs, register Lisp_Object *args)
1052 {
1053 Lisp_Object bus, service, path, interface, method;
1054 Lisp_Object result;
1055 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
1056 DBusConnection *connection;
1057 DBusMessage *dmessage;
1058 DBusMessage *reply;
1059 DBusMessageIter iter;
1060 DBusError derror;
1061 unsigned int dtype;
1062 int timeout = -1;
1063 int i = 5;
1064 char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1065
1066 /* Check parameters. */
1067 bus = args[0];
1068 service = args[1];
1069 path = args[2];
1070 interface = args[3];
1071 method = args[4];
1072
1073 CHECK_STRING (service);
1074 CHECK_STRING (path);
1075 CHECK_STRING (interface);
1076 CHECK_STRING (method);
1077 GCPRO5 (bus, service, path, interface, method);
1078
1079 XD_DEBUG_MESSAGE ("%s %s %s %s",
1080 SDATA (service),
1081 SDATA (path),
1082 SDATA (interface),
1083 SDATA (method));
1084
1085 /* Open a connection to the bus. */
1086 connection = xd_initialize (bus, TRUE);
1087
1088 /* Create the message. */
1089 dmessage = dbus_message_new_method_call (SDATA (service),
1090 SDATA (path),
1091 SDATA (interface),
1092 SDATA (method));
1093 UNGCPRO;
1094 if (dmessage == NULL)
1095 XD_SIGNAL1 (build_string ("Unable to create a new message"));
1096
1097 /* Check for timeout parameter. */
1098 if ((i+2 <= nargs) && (EQ ((args[i]), QCdbus_timeout)))
1099 {
1100 CHECK_NATNUM (args[i+1]);
1101 timeout = XUINT (args[i+1]);
1102 i = i+2;
1103 }
1104
1105 /* Initialize parameter list of message. */
1106 dbus_message_iter_init_append (dmessage, &iter);
1107
1108 /* Append parameters to the message. */
1109 for (; i < nargs; ++i)
1110 {
1111 dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1112 if (XD_DBUS_TYPE_P (args[i]))
1113 {
1114 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1115 XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1116 XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-4,
1117 SDATA (format2 ("%s", args[i], Qnil)),
1118 SDATA (format2 ("%s", args[i+1], Qnil)));
1119 ++i;
1120 }
1121 else
1122 {
1123 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1124 XD_DEBUG_MESSAGE ("Parameter%d %s", i-4,
1125 SDATA (format2 ("%s", args[i], Qnil)));
1126 }
1127
1128 /* Check for valid signature. We use DBUS_TYPE_INVALID as
1129 indication that there is no parent type. */
1130 xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1131
1132 xd_append_arg (dtype, args[i], &iter);
1133 }
1134
1135 /* Send the message. */
1136 dbus_error_init (&derror);
1137 reply = dbus_connection_send_with_reply_and_block (connection,
1138 dmessage,
1139 timeout,
1140 &derror);
1141
1142 if (dbus_error_is_set (&derror))
1143 XD_ERROR (derror);
1144
1145 if (reply == NULL)
1146 XD_SIGNAL1 (build_string ("No reply"));
1147
1148 XD_DEBUG_MESSAGE ("Message sent");
1149
1150 /* Collect the results. */
1151 result = Qnil;
1152 GCPRO1 (result);
1153
1154 if (dbus_message_iter_init (reply, &iter))
1155 {
1156 /* Loop over the parameters of the D-Bus reply message. Construct a
1157 Lisp list, which is returned by `dbus-call-method'. */
1158 while ((dtype = dbus_message_iter_get_arg_type (&iter))
1159 != DBUS_TYPE_INVALID)
1160 {
1161 result = Fcons (xd_retrieve_arg (dtype, &iter), result);
1162 dbus_message_iter_next (&iter);
1163 }
1164 }
1165 else
1166 {
1167 /* No arguments: just return nil. */
1168 }
1169
1170 /* Cleanup. */
1171 dbus_error_free (&derror);
1172 dbus_message_unref (dmessage);
1173 dbus_message_unref (reply);
1174
1175 /* Return the result. If there is only one single Lisp object,
1176 return it as-it-is, otherwise return the reversed list. */
1177 if (XUINT (Flength (result)) == 1)
1178 RETURN_UNGCPRO (CAR_SAFE (result));
1179 else
1180 RETURN_UNGCPRO (Fnreverse (result));
1181 }
1182
1183 DEFUN ("dbus-call-method-asynchronously", Fdbus_call_method_asynchronously,
1184 Sdbus_call_method_asynchronously, 6, MANY, 0,
1185 doc: /* Call METHOD on the D-Bus BUS asynchronously.
1186
1187 BUS is either a Lisp symbol, `:system' or `:session', or a string
1188 denoting the bus address.
1189
1190 SERVICE is the D-Bus service name to be used. PATH is the D-Bus
1191 object path SERVICE is registered at. INTERFACE is an interface
1192 offered by SERVICE. It must provide METHOD.
1193
1194 HANDLER is a Lisp function, which is called when the corresponding
1195 return message has arrived. If HANDLER is nil, no return message will
1196 be expected.
1197
1198 If the parameter `:timeout' is given, the following integer TIMEOUT
1199 specifies the maximum number of milliseconds the method call must
1200 return. The default value is 25,000. If the method call doesn't
1201 return in time, a D-Bus error is raised.
1202
1203 All other arguments ARGS are passed to METHOD as arguments. They are
1204 converted into D-Bus types via the following rules:
1205
1206 t and nil => DBUS_TYPE_BOOLEAN
1207 number => DBUS_TYPE_UINT32
1208 integer => DBUS_TYPE_INT32
1209 float => DBUS_TYPE_DOUBLE
1210 string => DBUS_TYPE_STRING
1211 list => DBUS_TYPE_ARRAY
1212
1213 All arguments can be preceded by a type symbol. For details about
1214 type symbols, see Info node `(dbus)Type Conversion'.
1215
1216 Unless HANDLER is nil, the function returns a key into the hash table
1217 `dbus-registered-objects-table'. The corresponding entry in the hash
1218 table is removed, when the return message has been arrived, and
1219 HANDLER is called.
1220
1221 Example:
1222
1223 \(dbus-call-method-asynchronously
1224 :system "org.freedesktop.Hal" "/org/freedesktop/Hal/devices/computer"
1225 "org.freedesktop.Hal.Device" "GetPropertyString" 'message
1226 "system.kernel.machine")
1227
1228 => (:system 2)
1229
1230 -| i686
1231
1232 usage: (dbus-call-method-asynchronously BUS SERVICE PATH INTERFACE METHOD HANDLER &optional :timeout TIMEOUT &rest ARGS) */)
1233 (int nargs, register Lisp_Object *args)
1234 {
1235 Lisp_Object bus, service, path, interface, method, handler;
1236 Lisp_Object result;
1237 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5, gcpro6;
1238 DBusConnection *connection;
1239 DBusMessage *dmessage;
1240 DBusMessageIter iter;
1241 unsigned int dtype;
1242 int timeout = -1;
1243 int i = 6;
1244 char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1245
1246 /* Check parameters. */
1247 bus = args[0];
1248 service = args[1];
1249 path = args[2];
1250 interface = args[3];
1251 method = args[4];
1252 handler = args[5];
1253
1254 CHECK_STRING (service);
1255 CHECK_STRING (path);
1256 CHECK_STRING (interface);
1257 CHECK_STRING (method);
1258 if (!NILP (handler) && !FUNCTIONP (handler))
1259 wrong_type_argument (intern ("functionp"), handler);
1260 GCPRO6 (bus, service, path, interface, method, handler);
1261
1262 XD_DEBUG_MESSAGE ("%s %s %s %s",
1263 SDATA (service),
1264 SDATA (path),
1265 SDATA (interface),
1266 SDATA (method));
1267
1268 /* Open a connection to the bus. */
1269 connection = xd_initialize (bus, TRUE);
1270
1271 /* Create the message. */
1272 dmessage = dbus_message_new_method_call (SDATA (service),
1273 SDATA (path),
1274 SDATA (interface),
1275 SDATA (method));
1276 if (dmessage == NULL)
1277 XD_SIGNAL1 (build_string ("Unable to create a new message"));
1278
1279 /* Check for timeout parameter. */
1280 if ((i+2 <= nargs) && (EQ ((args[i]), QCdbus_timeout)))
1281 {
1282 CHECK_NATNUM (args[i+1]);
1283 timeout = XUINT (args[i+1]);
1284 i = i+2;
1285 }
1286
1287 /* Initialize parameter list of message. */
1288 dbus_message_iter_init_append (dmessage, &iter);
1289
1290 /* Append parameters to the message. */
1291 for (; i < nargs; ++i)
1292 {
1293 dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1294 if (XD_DBUS_TYPE_P (args[i]))
1295 {
1296 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1297 XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1298 XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-4,
1299 SDATA (format2 ("%s", args[i], Qnil)),
1300 SDATA (format2 ("%s", args[i+1], Qnil)));
1301 ++i;
1302 }
1303 else
1304 {
1305 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1306 XD_DEBUG_MESSAGE ("Parameter%d %s", i-4,
1307 SDATA (format2 ("%s", args[i], Qnil)));
1308 }
1309
1310 /* Check for valid signature. We use DBUS_TYPE_INVALID as
1311 indication that there is no parent type. */
1312 xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1313
1314 xd_append_arg (dtype, args[i], &iter);
1315 }
1316
1317 if (!NILP (handler))
1318 {
1319 /* Send the message. The message is just added to the outgoing
1320 message queue. */
1321 if (!dbus_connection_send_with_reply (connection, dmessage,
1322 NULL, timeout))
1323 XD_SIGNAL1 (build_string ("Cannot send message"));
1324
1325 /* The result is the key in Vdbus_registered_objects_table. */
1326 result = (list2 (bus, make_number (dbus_message_get_serial (dmessage))));
1327
1328 /* Create a hash table entry. */
1329 Fputhash (result, handler, Vdbus_registered_objects_table);
1330 }
1331 else
1332 {
1333 /* Send the message. The message is just added to the outgoing
1334 message queue. */
1335 if (!dbus_connection_send (connection, dmessage, NULL))
1336 XD_SIGNAL1 (build_string ("Cannot send message"));
1337
1338 result = Qnil;
1339 }
1340
1341 XD_DEBUG_MESSAGE ("Message sent");
1342
1343 /* Cleanup. */
1344 dbus_message_unref (dmessage);
1345
1346 /* Return the result. */
1347 RETURN_UNGCPRO (result);
1348 }
1349
1350 DEFUN ("dbus-method-return-internal", Fdbus_method_return_internal,
1351 Sdbus_method_return_internal,
1352 3, MANY, 0,
1353 doc: /* Return for message SERIAL on the D-Bus BUS.
1354 This is an internal function, it shall not be used outside dbus.el.
1355
1356 usage: (dbus-method-return-internal BUS SERIAL SERVICE &rest ARGS) */)
1357 (int nargs, register Lisp_Object *args)
1358 {
1359 Lisp_Object bus, serial, service;
1360 struct gcpro gcpro1, gcpro2, gcpro3;
1361 DBusConnection *connection;
1362 DBusMessage *dmessage;
1363 DBusMessageIter iter;
1364 unsigned int dtype;
1365 int i;
1366 char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1367
1368 /* Check parameters. */
1369 bus = args[0];
1370 serial = args[1];
1371 service = args[2];
1372
1373 CHECK_NUMBER (serial);
1374 CHECK_STRING (service);
1375 GCPRO3 (bus, serial, service);
1376
1377 XD_DEBUG_MESSAGE ("%lu %s ", (unsigned long) XUINT (serial), SDATA (service));
1378
1379 /* Open a connection to the bus. */
1380 connection = xd_initialize (bus, TRUE);
1381
1382 /* Create the message. */
1383 dmessage = dbus_message_new (DBUS_MESSAGE_TYPE_METHOD_RETURN);
1384 if ((dmessage == NULL)
1385 || (!dbus_message_set_reply_serial (dmessage, XUINT (serial)))
1386 || (!dbus_message_set_destination (dmessage, SDATA (service))))
1387 {
1388 UNGCPRO;
1389 XD_SIGNAL1 (build_string ("Unable to create a return message"));
1390 }
1391
1392 UNGCPRO;
1393
1394 /* Initialize parameter list of message. */
1395 dbus_message_iter_init_append (dmessage, &iter);
1396
1397 /* Append parameters to the message. */
1398 for (i = 3; i < nargs; ++i)
1399 {
1400 dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1401 if (XD_DBUS_TYPE_P (args[i]))
1402 {
1403 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1404 XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1405 XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-2,
1406 SDATA (format2 ("%s", args[i], Qnil)),
1407 SDATA (format2 ("%s", args[i+1], Qnil)));
1408 ++i;
1409 }
1410 else
1411 {
1412 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1413 XD_DEBUG_MESSAGE ("Parameter%d %s", i-2,
1414 SDATA (format2 ("%s", args[i], Qnil)));
1415 }
1416
1417 /* Check for valid signature. We use DBUS_TYPE_INVALID as
1418 indication that there is no parent type. */
1419 xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1420
1421 xd_append_arg (dtype, args[i], &iter);
1422 }
1423
1424 /* Send the message. The message is just added to the outgoing
1425 message queue. */
1426 if (!dbus_connection_send (connection, dmessage, NULL))
1427 XD_SIGNAL1 (build_string ("Cannot send message"));
1428
1429 XD_DEBUG_MESSAGE ("Message sent");
1430
1431 /* Cleanup. */
1432 dbus_message_unref (dmessage);
1433
1434 /* Return. */
1435 return Qt;
1436 }
1437
1438 DEFUN ("dbus-method-error-internal", Fdbus_method_error_internal,
1439 Sdbus_method_error_internal,
1440 3, MANY, 0,
1441 doc: /* Return error message for message SERIAL on the D-Bus BUS.
1442 This is an internal function, it shall not be used outside dbus.el.
1443
1444 usage: (dbus-method-error-internal BUS SERIAL SERVICE &rest ARGS) */)
1445 (int nargs, register Lisp_Object *args)
1446 {
1447 Lisp_Object bus, serial, service;
1448 struct gcpro gcpro1, gcpro2, gcpro3;
1449 DBusConnection *connection;
1450 DBusMessage *dmessage;
1451 DBusMessageIter iter;
1452 unsigned int dtype;
1453 int i;
1454 char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1455
1456 /* Check parameters. */
1457 bus = args[0];
1458 serial = args[1];
1459 service = args[2];
1460
1461 CHECK_NUMBER (serial);
1462 CHECK_STRING (service);
1463 GCPRO3 (bus, serial, service);
1464
1465 XD_DEBUG_MESSAGE ("%lu %s ", (unsigned long) XUINT (serial), SDATA (service));
1466
1467 /* Open a connection to the bus. */
1468 connection = xd_initialize (bus, TRUE);
1469
1470 /* Create the message. */
1471 dmessage = dbus_message_new (DBUS_MESSAGE_TYPE_ERROR);
1472 if ((dmessage == NULL)
1473 || (!dbus_message_set_error_name (dmessage, DBUS_ERROR_FAILED))
1474 || (!dbus_message_set_reply_serial (dmessage, XUINT (serial)))
1475 || (!dbus_message_set_destination (dmessage, SDATA (service))))
1476 {
1477 UNGCPRO;
1478 XD_SIGNAL1 (build_string ("Unable to create a error message"));
1479 }
1480
1481 UNGCPRO;
1482
1483 /* Initialize parameter list of message. */
1484 dbus_message_iter_init_append (dmessage, &iter);
1485
1486 /* Append parameters to the message. */
1487 for (i = 3; i < nargs; ++i)
1488 {
1489 dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1490 if (XD_DBUS_TYPE_P (args[i]))
1491 {
1492 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1493 XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1494 XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-2,
1495 SDATA (format2 ("%s", args[i], Qnil)),
1496 SDATA (format2 ("%s", args[i+1], Qnil)));
1497 ++i;
1498 }
1499 else
1500 {
1501 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1502 XD_DEBUG_MESSAGE ("Parameter%d %s", i-2,
1503 SDATA (format2 ("%s", args[i], Qnil)));
1504 }
1505
1506 /* Check for valid signature. We use DBUS_TYPE_INVALID as
1507 indication that there is no parent type. */
1508 xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1509
1510 xd_append_arg (dtype, args[i], &iter);
1511 }
1512
1513 /* Send the message. The message is just added to the outgoing
1514 message queue. */
1515 if (!dbus_connection_send (connection, dmessage, NULL))
1516 XD_SIGNAL1 (build_string ("Cannot send message"));
1517
1518 XD_DEBUG_MESSAGE ("Message sent");
1519
1520 /* Cleanup. */
1521 dbus_message_unref (dmessage);
1522
1523 /* Return. */
1524 return Qt;
1525 }
1526
1527 DEFUN ("dbus-send-signal", Fdbus_send_signal, Sdbus_send_signal, 5, MANY, 0,
1528 doc: /* Send signal SIGNAL on the D-Bus BUS.
1529
1530 BUS is either a Lisp symbol, `:system' or `:session', or a string
1531 denoting the bus address.
1532
1533 SERVICE is the D-Bus service name SIGNAL is sent from. PATH is the
1534 D-Bus object path SERVICE is registered at. INTERFACE is an interface
1535 offered by SERVICE. It must provide signal SIGNAL.
1536
1537 All other arguments ARGS are passed to SIGNAL as arguments. They are
1538 converted into D-Bus types via the following rules:
1539
1540 t and nil => DBUS_TYPE_BOOLEAN
1541 number => DBUS_TYPE_UINT32
1542 integer => DBUS_TYPE_INT32
1543 float => DBUS_TYPE_DOUBLE
1544 string => DBUS_TYPE_STRING
1545 list => DBUS_TYPE_ARRAY
1546
1547 All arguments can be preceded by a type symbol. For details about
1548 type symbols, see Info node `(dbus)Type Conversion'.
1549
1550 Example:
1551
1552 \(dbus-send-signal
1553 :session "org.gnu.Emacs" "/org/gnu/Emacs"
1554 "org.gnu.Emacs.FileManager" "FileModified" "/home/albinus/.emacs")
1555
1556 usage: (dbus-send-signal BUS SERVICE PATH INTERFACE SIGNAL &rest ARGS) */)
1557 (int nargs, register Lisp_Object *args)
1558 {
1559 Lisp_Object bus, service, path, interface, signal;
1560 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
1561 DBusConnection *connection;
1562 DBusMessage *dmessage;
1563 DBusMessageIter iter;
1564 unsigned int dtype;
1565 int i;
1566 char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1567
1568 /* Check parameters. */
1569 bus = args[0];
1570 service = args[1];
1571 path = args[2];
1572 interface = args[3];
1573 signal = args[4];
1574
1575 CHECK_STRING (service);
1576 CHECK_STRING (path);
1577 CHECK_STRING (interface);
1578 CHECK_STRING (signal);
1579 GCPRO5 (bus, service, path, interface, signal);
1580
1581 XD_DEBUG_MESSAGE ("%s %s %s %s",
1582 SDATA (service),
1583 SDATA (path),
1584 SDATA (interface),
1585 SDATA (signal));
1586
1587 /* Open a connection to the bus. */
1588 connection = xd_initialize (bus, TRUE);
1589
1590 /* Create the message. */
1591 dmessage = dbus_message_new_signal (SDATA (path),
1592 SDATA (interface),
1593 SDATA (signal));
1594 UNGCPRO;
1595 if (dmessage == NULL)
1596 XD_SIGNAL1 (build_string ("Unable to create a new message"));
1597
1598 /* Initialize parameter list of message. */
1599 dbus_message_iter_init_append (dmessage, &iter);
1600
1601 /* Append parameters to the message. */
1602 for (i = 5; i < nargs; ++i)
1603 {
1604 dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1605 if (XD_DBUS_TYPE_P (args[i]))
1606 {
1607 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1608 XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1609 XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-4,
1610 SDATA (format2 ("%s", args[i], Qnil)),
1611 SDATA (format2 ("%s", args[i+1], Qnil)));
1612 ++i;
1613 }
1614 else
1615 {
1616 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1617 XD_DEBUG_MESSAGE ("Parameter%d %s", i-4,
1618 SDATA (format2 ("%s", args[i], Qnil)));
1619 }
1620
1621 /* Check for valid signature. We use DBUS_TYPE_INVALID as
1622 indication that there is no parent type. */
1623 xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1624
1625 xd_append_arg (dtype, args[i], &iter);
1626 }
1627
1628 /* Send the message. The message is just added to the outgoing
1629 message queue. */
1630 if (!dbus_connection_send (connection, dmessage, NULL))
1631 XD_SIGNAL1 (build_string ("Cannot send message"));
1632
1633 XD_DEBUG_MESSAGE ("Signal sent");
1634
1635 /* Cleanup. */
1636 dbus_message_unref (dmessage);
1637
1638 /* Return. */
1639 return Qt;
1640 }
1641
1642 /* Read one queued incoming message of the D-Bus BUS.
1643 BUS is either a Lisp symbol, :system or :session, or a string denoting
1644 the bus address. */
1645 static void
1646 xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
1647 {
1648 Lisp_Object args, key, value;
1649 struct gcpro gcpro1;
1650 struct input_event event;
1651 DBusMessage *dmessage;
1652 DBusMessageIter iter;
1653 unsigned int dtype;
1654 int mtype, serial;
1655 const char *uname, *path, *interface, *member;
1656
1657 dmessage = dbus_connection_pop_message (connection);
1658
1659 /* Return if there is no queued message. */
1660 if (dmessage == NULL)
1661 return;
1662
1663 /* Collect the parameters. */
1664 args = Qnil;
1665 GCPRO1 (args);
1666
1667 /* Loop over the resulting parameters. Construct a list. */
1668 if (dbus_message_iter_init (dmessage, &iter))
1669 {
1670 while ((dtype = dbus_message_iter_get_arg_type (&iter))
1671 != DBUS_TYPE_INVALID)
1672 {
1673 args = Fcons (xd_retrieve_arg (dtype, &iter), args);
1674 dbus_message_iter_next (&iter);
1675 }
1676 /* The arguments are stored in reverse order. Reorder them. */
1677 args = Fnreverse (args);
1678 }
1679
1680 /* Read message type, message serial, unique name, object path,
1681 interface and member from the message. */
1682 mtype = dbus_message_get_type (dmessage);
1683 serial =
1684 ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1685 || (mtype == DBUS_MESSAGE_TYPE_ERROR))
1686 ? dbus_message_get_reply_serial (dmessage)
1687 : dbus_message_get_serial (dmessage);
1688 uname = dbus_message_get_sender (dmessage);
1689 path = dbus_message_get_path (dmessage);
1690 interface = dbus_message_get_interface (dmessage);
1691 member = dbus_message_get_member (dmessage);
1692
1693 XD_DEBUG_MESSAGE ("Event received: %s %d %s %s %s %s %s",
1694 (mtype == DBUS_MESSAGE_TYPE_INVALID)
1695 ? "DBUS_MESSAGE_TYPE_INVALID"
1696 : (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1697 ? "DBUS_MESSAGE_TYPE_METHOD_CALL"
1698 : (mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1699 ? "DBUS_MESSAGE_TYPE_METHOD_RETURN"
1700 : (mtype == DBUS_MESSAGE_TYPE_ERROR)
1701 ? "DBUS_MESSAGE_TYPE_ERROR"
1702 : "DBUS_MESSAGE_TYPE_SIGNAL",
1703 serial, uname, path, interface, member,
1704 SDATA (format2 ("%s", args, Qnil)));
1705
1706 if ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1707 || (mtype == DBUS_MESSAGE_TYPE_ERROR))
1708 {
1709 /* Search for a registered function of the message. */
1710 key = list2 (bus, make_number (serial));
1711 value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1712
1713 /* There shall be exactly one entry. Construct an event. */
1714 if (NILP (value))
1715 goto cleanup;
1716
1717 /* Remove the entry. */
1718 Fremhash (key, Vdbus_registered_objects_table);
1719
1720 /* Construct an event. */
1721 EVENT_INIT (event);
1722 event.kind = DBUS_EVENT;
1723 event.frame_or_window = Qnil;
1724 event.arg = Fcons (value, args);
1725 }
1726
1727 else /* (mtype != DBUS_MESSAGE_TYPE_METHOD_RETURN) */
1728 {
1729 /* Vdbus_registered_objects_table requires non-nil interface and
1730 member. */
1731 if ((interface == NULL) || (member == NULL))
1732 goto cleanup;
1733
1734 /* Search for a registered function of the message. */
1735 key = list3 (bus, build_string (interface), build_string (member));
1736 value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1737
1738 /* Loop over the registered functions. Construct an event. */
1739 while (!NILP (value))
1740 {
1741 key = CAR_SAFE (value);
1742 /* key has the structure (UNAME SERVICE PATH HANDLER). */
1743 if (((uname == NULL)
1744 || (NILP (CAR_SAFE (key)))
1745 || (strcmp (uname, SDATA (CAR_SAFE (key))) == 0))
1746 && ((path == NULL)
1747 || (NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1748 || (strcmp (path,
1749 SDATA (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1750 == 0))
1751 && (!NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))))))
1752 {
1753 EVENT_INIT (event);
1754 event.kind = DBUS_EVENT;
1755 event.frame_or_window = Qnil;
1756 event.arg = Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))),
1757 args);
1758 break;
1759 }
1760 value = CDR_SAFE (value);
1761 }
1762
1763 if (NILP (value))
1764 goto cleanup;
1765 }
1766
1767 /* Add type, serial, uname, path, interface and member to the event. */
1768 event.arg = Fcons ((member == NULL ? Qnil : build_string (member)),
1769 event.arg);
1770 event.arg = Fcons ((interface == NULL ? Qnil : build_string (interface)),
1771 event.arg);
1772 event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
1773 event.arg);
1774 event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
1775 event.arg);
1776 event.arg = Fcons (make_number (serial), event.arg);
1777 event.arg = Fcons (make_number (mtype), event.arg);
1778
1779 /* Add the bus symbol to the event. */
1780 event.arg = Fcons (bus, event.arg);
1781
1782 /* Store it into the input event queue. */
1783 kbd_buffer_store_event (&event);
1784
1785 XD_DEBUG_MESSAGE ("Event stored: %s",
1786 SDATA (format2 ("%s", event.arg, Qnil)));
1787
1788 /* Cleanup. */
1789 cleanup:
1790 dbus_message_unref (dmessage);
1791
1792 UNGCPRO;
1793 }
1794
1795 /* Read queued incoming messages of the D-Bus BUS.
1796 BUS is either a Lisp symbol, :system or :session, or a string denoting
1797 the bus address. */
1798 static Lisp_Object
1799 xd_read_message (Lisp_Object bus)
1800 {
1801 /* Open a connection to the bus. */
1802 DBusConnection *connection = xd_initialize (bus, TRUE);
1803
1804 /* Non blocking read of the next available message. */
1805 dbus_connection_read_write (connection, 0);
1806
1807 while (dbus_connection_get_dispatch_status (connection)
1808 != DBUS_DISPATCH_COMPLETE)
1809 xd_read_message_1 (connection, bus);
1810 return Qnil;
1811 }
1812
1813 /* Callback called when something is ready to read or write. */
1814 static void
1815 xd_read_queued_messages (int fd, void *data, int for_read)
1816 {
1817 Lisp_Object busp = Vdbus_registered_buses;
1818 Lisp_Object bus = Qnil;
1819
1820 /* Find bus related to fd. */
1821 if (data != NULL)
1822 while (!NILP (busp))
1823 {
1824 if (data == (void*) XHASH (CAR_SAFE (busp)))
1825 bus = CAR_SAFE (busp);
1826 busp = CDR_SAFE (busp);
1827 }
1828
1829 if (NILP(bus))
1830 return;
1831
1832 /* We ignore all Lisp errors during the call. */
1833 xd_in_read_queued_messages = 1;
1834 internal_catch (Qdbus_error, xd_read_message, bus);
1835 xd_in_read_queued_messages = 0;
1836 }
1837
1838 DEFUN ("dbus-register-signal", Fdbus_register_signal, Sdbus_register_signal,
1839 6, MANY, 0,
1840 doc: /* Register for signal SIGNAL on the D-Bus BUS.
1841
1842 BUS is either a Lisp symbol, `:system' or `:session', or a string
1843 denoting the bus address.
1844
1845 SERVICE is the D-Bus service name used by the sending D-Bus object.
1846 It can be either a known name or the unique name of the D-Bus object
1847 sending the signal. When SERVICE is nil, related signals from all
1848 D-Bus objects shall be accepted.
1849
1850 PATH is the D-Bus object path SERVICE is registered. It can also be
1851 nil if the path name of incoming signals shall not be checked.
1852
1853 INTERFACE is an interface offered by SERVICE. It must provide SIGNAL.
1854 HANDLER is a Lisp function to be called when the signal is received.
1855 It must accept as arguments the values SIGNAL is sending.
1856
1857 All other arguments ARGS, if specified, must be strings. They stand
1858 for the respective arguments of the signal in their order, and are
1859 used for filtering as well. A nil argument might be used to preserve
1860 the order.
1861
1862 INTERFACE, SIGNAL and HANDLER must not be nil. Example:
1863
1864 \(defun my-signal-handler (device)
1865 (message "Device %s added" device))
1866
1867 \(dbus-register-signal
1868 :system "org.freedesktop.Hal" "/org/freedesktop/Hal/Manager"
1869 "org.freedesktop.Hal.Manager" "DeviceAdded" 'my-signal-handler)
1870
1871 => ((:system "org.freedesktop.Hal.Manager" "DeviceAdded")
1872 ("org.freedesktop.Hal" "/org/freedesktop/Hal/Manager" my-signal-handler))
1873
1874 `dbus-register-signal' returns an object, which can be used in
1875 `dbus-unregister-object' for removing the registration.
1876
1877 usage: (dbus-register-signal BUS SERVICE PATH INTERFACE SIGNAL HANDLER &rest ARGS) */)
1878 (int nargs, register Lisp_Object *args)
1879 {
1880 Lisp_Object bus, service, path, interface, signal, handler;
1881 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5, gcpro6;
1882 Lisp_Object uname, key, key1, value;
1883 DBusConnection *connection;
1884 int i;
1885 char rule[DBUS_MAXIMUM_MATCH_RULE_LENGTH];
1886 char x[DBUS_MAXIMUM_MATCH_RULE_LENGTH];
1887 DBusError derror;
1888
1889 /* Check parameters. */
1890 bus = args[0];
1891 service = args[1];
1892 path = args[2];
1893 interface = args[3];
1894 signal = args[4];
1895 handler = args[5];
1896
1897 if (!NILP (service)) CHECK_STRING (service);
1898 if (!NILP (path)) CHECK_STRING (path);
1899 CHECK_STRING (interface);
1900 CHECK_STRING (signal);
1901 if (!FUNCTIONP (handler))
1902 wrong_type_argument (intern ("functionp"), handler);
1903 GCPRO6 (bus, service, path, interface, signal, handler);
1904
1905 /* Retrieve unique name of service. If service is a known name, we
1906 will register for the corresponding unique name, if any. Signals
1907 are sent always with the unique name as sender. Note: the unique
1908 name of "org.freedesktop.DBus" is that string itself. */
1909 if ((STRINGP (service))
1910 && (SBYTES (service) > 0)
1911 && (strcmp (SDATA (service), DBUS_SERVICE_DBUS) != 0)
1912 && (strncmp (SDATA (service), ":", 1) != 0))
1913 {
1914 uname = call2 (intern ("dbus-get-name-owner"), bus, service);
1915 /* When there is no unique name, we mark it with an empty
1916 string. */
1917 if (NILP (uname))
1918 uname = empty_unibyte_string;
1919 }
1920 else
1921 uname = service;
1922
1923 /* Create a matching rule if the unique name exists (when no
1924 wildcard). */
1925 if (NILP (uname) || (SBYTES (uname) > 0))
1926 {
1927 /* Open a connection to the bus. */
1928 connection = xd_initialize (bus, TRUE);
1929
1930 /* Create a rule to receive related signals. */
1931 sprintf (rule,
1932 "type='signal',interface='%s',member='%s'",
1933 SDATA (interface),
1934 SDATA (signal));
1935
1936 /* Add unique name and path to the rule if they are non-nil. */
1937 if (!NILP (uname))
1938 {
1939 sprintf (x, ",sender='%s'", SDATA (uname));
1940 strcat (rule, x);
1941 }
1942
1943 if (!NILP (path))
1944 {
1945 sprintf (x, ",path='%s'", SDATA (path));
1946 strcat (rule, x);
1947 }
1948
1949 /* Add arguments to the rule if they are non-nil. */
1950 for (i = 6; i < nargs; ++i)
1951 if (!NILP (args[i]))
1952 {
1953 CHECK_STRING (args[i]);
1954 sprintf (x, ",arg%d='%s'", i-6, SDATA (args[i]));
1955 strcat (rule, x);
1956 }
1957
1958 /* Add the rule to the bus. */
1959 dbus_error_init (&derror);
1960 dbus_bus_add_match (connection, rule, &derror);
1961 if (dbus_error_is_set (&derror))
1962 {
1963 UNGCPRO;
1964 XD_ERROR (derror);
1965 }
1966
1967 /* Cleanup. */
1968 dbus_error_free (&derror);
1969
1970 XD_DEBUG_MESSAGE ("Matching rule \"%s\" created", rule);
1971 }
1972
1973 /* Create a hash table entry. */
1974 key = list3 (bus, interface, signal);
1975 key1 = list4 (uname, service, path, handler);
1976 value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1977
1978 if (NILP (Fmember (key1, value)))
1979 Fputhash (key, Fcons (key1, value), Vdbus_registered_objects_table);
1980
1981 /* Return object. */
1982 RETURN_UNGCPRO (list2 (key, list3 (service, path, handler)));
1983 }
1984
1985 DEFUN ("dbus-register-method", Fdbus_register_method, Sdbus_register_method,
1986 6, 6, 0,
1987 doc: /* Register for method METHOD on the D-Bus BUS.
1988
1989 BUS is either a Lisp symbol, `:system' or `:session', or a string
1990 denoting the bus address.
1991
1992 SERVICE is the D-Bus service name of the D-Bus object METHOD is
1993 registered for. It must be a known name.
1994
1995 PATH is the D-Bus object path SERVICE is registered. INTERFACE is the
1996 interface offered by SERVICE. It must provide METHOD. HANDLER is a
1997 Lisp function to be called when a method call is received. It must
1998 accept the input arguments of METHOD. The return value of HANDLER is
1999 used for composing the returning D-Bus message. */)
2000 (Lisp_Object bus, Lisp_Object service, Lisp_Object path, Lisp_Object interface, Lisp_Object method, Lisp_Object handler)
2001 {
2002 Lisp_Object key, key1, value;
2003 DBusConnection *connection;
2004 int result;
2005 DBusError derror;
2006
2007 /* Check parameters. */
2008 CHECK_STRING (service);
2009 CHECK_STRING (path);
2010 CHECK_STRING (interface);
2011 CHECK_STRING (method);
2012 if (!FUNCTIONP (handler))
2013 wrong_type_argument (intern ("functionp"), handler);
2014 /* TODO: We must check for a valid service name, otherwise there is
2015 a segmentation fault. */
2016
2017 /* Open a connection to the bus. */
2018 connection = xd_initialize (bus, TRUE);
2019
2020 /* Request the known name from the bus. We can ignore the result,
2021 it is set to -1 if there is an error - kind of redundancy. */
2022 dbus_error_init (&derror);
2023 result = dbus_bus_request_name (connection, SDATA (service), 0, &derror);
2024 if (dbus_error_is_set (&derror))
2025 XD_ERROR (derror);
2026
2027 /* Create a hash table entry. We use nil for the unique name,
2028 because the method might be called from anybody. */
2029 key = list3 (bus, interface, method);
2030 key1 = list4 (Qnil, service, path, handler);
2031 value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
2032
2033 if (NILP (Fmember (key1, value)))
2034 Fputhash (key, Fcons (key1, value), Vdbus_registered_objects_table);
2035
2036 /* Cleanup. */
2037 dbus_error_free (&derror);
2038
2039 /* Return object. */
2040 return list2 (key, list3 (service, path, handler));
2041 }
2042
2043 \f
2044 void
2045 syms_of_dbusbind (void)
2046 {
2047
2048 Qdbus_init_bus = intern_c_string ("dbus-init-bus");
2049 staticpro (&Qdbus_init_bus);
2050 defsubr (&Sdbus_init_bus);
2051
2052 Qdbus_close_bus = intern_c_string ("dbus-close-bus");
2053 staticpro (&Qdbus_close_bus);
2054 defsubr (&Sdbus_close_bus);
2055
2056 Qdbus_get_unique_name = intern_c_string ("dbus-get-unique-name");
2057 staticpro (&Qdbus_get_unique_name);
2058 defsubr (&Sdbus_get_unique_name);
2059
2060 Qdbus_call_method = intern_c_string ("dbus-call-method");
2061 staticpro (&Qdbus_call_method);
2062 defsubr (&Sdbus_call_method);
2063
2064 Qdbus_call_method_asynchronously = intern_c_string ("dbus-call-method-asynchronously");
2065 staticpro (&Qdbus_call_method_asynchronously);
2066 defsubr (&Sdbus_call_method_asynchronously);
2067
2068 Qdbus_method_return_internal = intern_c_string ("dbus-method-return-internal");
2069 staticpro (&Qdbus_method_return_internal);
2070 defsubr (&Sdbus_method_return_internal);
2071
2072 Qdbus_method_error_internal = intern_c_string ("dbus-method-error-internal");
2073 staticpro (&Qdbus_method_error_internal);
2074 defsubr (&Sdbus_method_error_internal);
2075
2076 Qdbus_send_signal = intern_c_string ("dbus-send-signal");
2077 staticpro (&Qdbus_send_signal);
2078 defsubr (&Sdbus_send_signal);
2079
2080 Qdbus_register_signal = intern_c_string ("dbus-register-signal");
2081 staticpro (&Qdbus_register_signal);
2082 defsubr (&Sdbus_register_signal);
2083
2084 Qdbus_register_method = intern_c_string ("dbus-register-method");
2085 staticpro (&Qdbus_register_method);
2086 defsubr (&Sdbus_register_method);
2087
2088 Qdbus_error = intern_c_string ("dbus-error");
2089 staticpro (&Qdbus_error);
2090 Fput (Qdbus_error, Qerror_conditions,
2091 list2 (Qdbus_error, Qerror));
2092 Fput (Qdbus_error, Qerror_message,
2093 make_pure_c_string ("D-Bus error"));
2094
2095 QCdbus_system_bus = intern_c_string (":system");
2096 staticpro (&QCdbus_system_bus);
2097
2098 QCdbus_session_bus = intern_c_string (":session");
2099 staticpro (&QCdbus_session_bus);
2100
2101 QCdbus_timeout = intern_c_string (":timeout");
2102 staticpro (&QCdbus_timeout);
2103
2104 QCdbus_type_byte = intern_c_string (":byte");
2105 staticpro (&QCdbus_type_byte);
2106
2107 QCdbus_type_boolean = intern_c_string (":boolean");
2108 staticpro (&QCdbus_type_boolean);
2109
2110 QCdbus_type_int16 = intern_c_string (":int16");
2111 staticpro (&QCdbus_type_int16);
2112
2113 QCdbus_type_uint16 = intern_c_string (":uint16");
2114 staticpro (&QCdbus_type_uint16);
2115
2116 QCdbus_type_int32 = intern_c_string (":int32");
2117 staticpro (&QCdbus_type_int32);
2118
2119 QCdbus_type_uint32 = intern_c_string (":uint32");
2120 staticpro (&QCdbus_type_uint32);
2121
2122 QCdbus_type_int64 = intern_c_string (":int64");
2123 staticpro (&QCdbus_type_int64);
2124
2125 QCdbus_type_uint64 = intern_c_string (":uint64");
2126 staticpro (&QCdbus_type_uint64);
2127
2128 QCdbus_type_double = intern_c_string (":double");
2129 staticpro (&QCdbus_type_double);
2130
2131 QCdbus_type_string = intern_c_string (":string");
2132 staticpro (&QCdbus_type_string);
2133
2134 QCdbus_type_object_path = intern_c_string (":object-path");
2135 staticpro (&QCdbus_type_object_path);
2136
2137 QCdbus_type_signature = intern_c_string (":signature");
2138 staticpro (&QCdbus_type_signature);
2139
2140 #ifdef DBUS_TYPE_UNIX_FD
2141 QCdbus_type_unix_fd = intern_c_string (":unix-fd");
2142 staticpro (&QCdbus_type_unix_fd);
2143 #endif
2144
2145 QCdbus_type_array = intern_c_string (":array");
2146 staticpro (&QCdbus_type_array);
2147
2148 QCdbus_type_variant = intern_c_string (":variant");
2149 staticpro (&QCdbus_type_variant);
2150
2151 QCdbus_type_struct = intern_c_string (":struct");
2152 staticpro (&QCdbus_type_struct);
2153
2154 QCdbus_type_dict_entry = intern_c_string (":dict-entry");
2155 staticpro (&QCdbus_type_dict_entry);
2156
2157 DEFVAR_LISP ("dbus-registered-buses",
2158 &Vdbus_registered_buses,
2159 doc: /* List of D-Bus buses we are polling for messages. */);
2160 Vdbus_registered_buses = Qnil;
2161
2162 DEFVAR_LISP ("dbus-registered-objects-table",
2163 &Vdbus_registered_objects_table,
2164 doc: /* Hash table of registered functions for D-Bus.
2165
2166 There are two different uses of the hash table: for accessing
2167 registered interfaces properties, targeted by signals or method calls,
2168 and for calling handlers in case of non-blocking method call returns.
2169
2170 In the first case, the key in the hash table is the list (BUS
2171 INTERFACE MEMBER). BUS is either a Lisp symbol, `:system' or
2172 `:session', or a string denoting the bus address. INTERFACE is a
2173 string which denotes a D-Bus interface, and MEMBER, also a string, is
2174 either a method, a signal or a property INTERFACE is offering. All
2175 arguments but BUS must not be nil.
2176
2177 The value in the hash table is a list of quadruple lists
2178 \((UNAME SERVICE PATH OBJECT) (UNAME SERVICE PATH OBJECT) ...).
2179 SERVICE is the service name as registered, UNAME is the corresponding
2180 unique name. In case of registered methods and properties, UNAME is
2181 nil. PATH is the object path of the sending object. All of them can
2182 be nil, which means a wildcard then. OBJECT is either the handler to
2183 be called when a D-Bus message, which matches the key criteria,
2184 arrives (methods and signals), or a cons cell containing the value of
2185 the property.
2186
2187 In the second case, the key in the hash table is the list (BUS
2188 SERIAL). BUS is either a Lisp symbol, `:system' or `:session', or a
2189 string denoting the bus address. SERIAL is the serial number of the
2190 non-blocking method call, a reply is expected. Both arguments must
2191 not be nil. The value in the hash table is HANDLER, the function to
2192 be called when the D-Bus reply message arrives. */);
2193 {
2194 Lisp_Object args[2];
2195 args[0] = QCtest;
2196 args[1] = Qequal;
2197 Vdbus_registered_objects_table = Fmake_hash_table (2, args);
2198 }
2199
2200 DEFVAR_LISP ("dbus-debug", &Vdbus_debug,
2201 doc: /* If non-nil, debug messages of D-Bus bindings are raised. */);
2202 #ifdef DBUS_DEBUG
2203 Vdbus_debug = Qt;
2204 /* We can also set environment variable DBUS_VERBOSE=1 in order to
2205 see more traces. This requires libdbus-1 to be configured with
2206 --enable-verbose-mode. */
2207 #else
2208 Vdbus_debug = Qnil;
2209 #endif
2210
2211 Fprovide (intern_c_string ("dbusbind"), Qnil);
2212
2213 }
2214
2215 #endif /* HAVE_DBUS */
2216
2217 /* arch-tag: 0e828477-b571-4fe4-b559-5c9211bc14b8
2218 (do not change this comment) */
Unnamed repository; edit this file 'description' to name the repository.