(Qfont_spec, Qfont_entity, Qfont_object): Extern them.
[bpt/emacs.git] / src / dbusbind.c
1 /* Elisp bindings for D-Bus.
2 Copyright (C) 2007, 2008 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 <stdio.h>
26 #include <dbus/dbus.h>
27 #include "lisp.h"
28 #include "frame.h"
29 #include "termhooks.h"
30 #include "keyboard.h"
31
32 \f
33 /* Subroutines. */
34 Lisp_Object Qdbus_get_unique_name;
35 Lisp_Object Qdbus_call_method;
36 Lisp_Object Qdbus_method_return_internal;
37 Lisp_Object Qdbus_send_signal;
38 Lisp_Object Qdbus_register_signal;
39 Lisp_Object Qdbus_register_method;
40
41 /* D-Bus error symbol. */
42 Lisp_Object Qdbus_error;
43
44 /* Lisp symbols of the system and session buses. */
45 Lisp_Object QCdbus_system_bus, QCdbus_session_bus;
46
47 /* Lisp symbol for method call timeout. */
48 Lisp_Object QCdbus_timeout;
49
50 /* Lisp symbols of D-Bus types. */
51 Lisp_Object QCdbus_type_byte, QCdbus_type_boolean;
52 Lisp_Object QCdbus_type_int16, QCdbus_type_uint16;
53 Lisp_Object QCdbus_type_int32, QCdbus_type_uint32;
54 Lisp_Object QCdbus_type_int64, QCdbus_type_uint64;
55 Lisp_Object QCdbus_type_double, QCdbus_type_string;
56 Lisp_Object QCdbus_type_object_path, QCdbus_type_signature;
57 Lisp_Object QCdbus_type_array, QCdbus_type_variant;
58 Lisp_Object QCdbus_type_struct, QCdbus_type_dict_entry;
59
60 /* Hash table which keeps function definitions. */
61 Lisp_Object Vdbus_registered_functions_table;
62
63 /* Whether to debug D-Bus. */
64 Lisp_Object Vdbus_debug;
65
66 \f
67 /* We use "xd_" and "XD_" as prefix for all internal symbols, because
68 we don't want to poison other namespaces with "dbus_". */
69
70 /* Raise a Lisp error from a D-Bus ERROR. */
71 #define XD_ERROR(error) \
72 do { \
73 char s[1024]; \
74 strcpy (s, error.message); \
75 dbus_error_free (&error); \
76 /* Remove the trailing newline. */ \
77 if (strchr (s, '\n') != NULL) \
78 s[strlen (s) - 1] = '\0'; \
79 xsignal1 (Qdbus_error, build_string (s)); \
80 } while (0)
81
82 /* Macros for debugging. In order to enable them, build with
83 "make MYCPPFLAGS='-DDBUS_DEBUG -Wall'". */
84 #ifdef DBUS_DEBUG
85 #define XD_DEBUG_MESSAGE(...) \
86 do { \
87 char s[1024]; \
88 sprintf (s, __VA_ARGS__); \
89 printf ("%s: %s\n", __func__, s); \
90 message ("%s: %s", __func__, s); \
91 } while (0)
92 #define XD_DEBUG_VALID_LISP_OBJECT_P(object) \
93 do { \
94 if (!valid_lisp_object_p (object)) \
95 { \
96 XD_DEBUG_MESSAGE ("%d Assertion failure", __LINE__); \
97 xsignal1 (Qdbus_error, build_string ("Assertion failure")); \
98 } \
99 } while (0)
100
101 #else /* !DBUS_DEBUG */
102 #define XD_DEBUG_MESSAGE(...) \
103 do { \
104 if (!NILP (Vdbus_debug)) \
105 { \
106 char s[1024]; \
107 sprintf (s, __VA_ARGS__); \
108 message ("%s: %s", __func__, s); \
109 } \
110 } while (0)
111 #define XD_DEBUG_VALID_LISP_OBJECT_P(object)
112 #endif
113
114 /* Check whether TYPE is a basic DBusType. */
115 #define XD_BASIC_DBUS_TYPE(type) \
116 ((type == DBUS_TYPE_BYTE) \
117 || (type == DBUS_TYPE_BOOLEAN) \
118 || (type == DBUS_TYPE_INT16) \
119 || (type == DBUS_TYPE_UINT16) \
120 || (type == DBUS_TYPE_INT32) \
121 || (type == DBUS_TYPE_UINT32) \
122 || (type == DBUS_TYPE_INT64) \
123 || (type == DBUS_TYPE_UINT64) \
124 || (type == DBUS_TYPE_DOUBLE) \
125 || (type == DBUS_TYPE_STRING) \
126 || (type == DBUS_TYPE_OBJECT_PATH) \
127 || (type == DBUS_TYPE_SIGNATURE))
128
129 /* Determine the DBusType of a given Lisp symbol. OBJECT must be one
130 of the predefined D-Bus type symbols. */
131 #define XD_SYMBOL_TO_DBUS_TYPE(object) \
132 ((EQ (object, QCdbus_type_byte)) ? DBUS_TYPE_BYTE \
133 : (EQ (object, QCdbus_type_boolean)) ? DBUS_TYPE_BOOLEAN \
134 : (EQ (object, QCdbus_type_int16)) ? DBUS_TYPE_INT16 \
135 : (EQ (object, QCdbus_type_uint16)) ? DBUS_TYPE_UINT16 \
136 : (EQ (object, QCdbus_type_int32)) ? DBUS_TYPE_INT32 \
137 : (EQ (object, QCdbus_type_uint32)) ? DBUS_TYPE_UINT32 \
138 : (EQ (object, QCdbus_type_int64)) ? DBUS_TYPE_INT64 \
139 : (EQ (object, QCdbus_type_uint64)) ? DBUS_TYPE_UINT64 \
140 : (EQ (object, QCdbus_type_double)) ? DBUS_TYPE_DOUBLE \
141 : (EQ (object, QCdbus_type_string)) ? DBUS_TYPE_STRING \
142 : (EQ (object, QCdbus_type_object_path)) ? DBUS_TYPE_OBJECT_PATH \
143 : (EQ (object, QCdbus_type_signature)) ? DBUS_TYPE_SIGNATURE \
144 : (EQ (object, QCdbus_type_array)) ? DBUS_TYPE_ARRAY \
145 : (EQ (object, QCdbus_type_variant)) ? DBUS_TYPE_VARIANT \
146 : (EQ (object, QCdbus_type_struct)) ? DBUS_TYPE_STRUCT \
147 : (EQ (object, QCdbus_type_dict_entry)) ? DBUS_TYPE_DICT_ENTRY \
148 : DBUS_TYPE_INVALID)
149
150 /* Check whether a Lisp symbol is a predefined D-Bus type symbol. */
151 #define XD_DBUS_TYPE_P(object) \
152 (SYMBOLP (object) && ((XD_SYMBOL_TO_DBUS_TYPE (object) != DBUS_TYPE_INVALID)))
153
154 /* Determine the DBusType of a given Lisp OBJECT. It is used to
155 convert Lisp objects, being arguments of `dbus-call-method' or
156 `dbus-send-signal', into corresponding C values appended as
157 arguments to a D-Bus message. */
158 #define XD_OBJECT_TO_DBUS_TYPE(object) \
159 ((EQ (object, Qt) || EQ (object, Qnil)) ? DBUS_TYPE_BOOLEAN \
160 : (NATNUMP (object)) ? DBUS_TYPE_UINT32 \
161 : (INTEGERP (object)) ? DBUS_TYPE_INT32 \
162 : (FLOATP (object)) ? DBUS_TYPE_DOUBLE \
163 : (STRINGP (object)) ? DBUS_TYPE_STRING \
164 : (XD_DBUS_TYPE_P (object)) ? XD_SYMBOL_TO_DBUS_TYPE (object) \
165 : (CONSP (object)) ? ((XD_DBUS_TYPE_P (CAR_SAFE (object))) \
166 ? XD_SYMBOL_TO_DBUS_TYPE (CAR_SAFE (object)) \
167 : DBUS_TYPE_ARRAY) \
168 : DBUS_TYPE_INVALID)
169
170 /* Return a list pointer which does not have a Lisp symbol as car. */
171 #define XD_NEXT_VALUE(object) \
172 ((XD_DBUS_TYPE_P (CAR_SAFE (object))) ? CDR_SAFE (object) : object)
173
174 /* Compute SIGNATURE of OBJECT. It must have a form that it can be
175 used in dbus_message_iter_open_container. DTYPE is the DBusType
176 the object is related to. It is passed as argument, because it
177 cannot be detected in basic type objects, when they are preceded by
178 a type symbol. PARENT_TYPE is the DBusType of a container this
179 signature is embedded, or DBUS_TYPE_INVALID. It is needed for the
180 check that DBUS_TYPE_DICT_ENTRY occurs only as array element. */
181 void
182 xd_signature(signature, dtype, parent_type, object)
183 char *signature;
184 unsigned int dtype, parent_type;
185 Lisp_Object object;
186 {
187 unsigned int subtype;
188 Lisp_Object elt;
189 char x[DBUS_MAXIMUM_SIGNATURE_LENGTH];
190
191 elt = object;
192
193 switch (dtype)
194 {
195 case DBUS_TYPE_BYTE:
196 case DBUS_TYPE_UINT16:
197 case DBUS_TYPE_UINT32:
198 case DBUS_TYPE_UINT64:
199 CHECK_NATNUM (object);
200 sprintf (signature, "%c", dtype);
201 break;
202
203 case DBUS_TYPE_BOOLEAN:
204 if (!EQ (object, Qt) && !EQ (object, Qnil))
205 wrong_type_argument (intern ("booleanp"), object);
206 sprintf (signature, "%c", dtype);
207 break;
208
209 case DBUS_TYPE_INT16:
210 case DBUS_TYPE_INT32:
211 case DBUS_TYPE_INT64:
212 CHECK_NUMBER (object);
213 sprintf (signature, "%c", dtype);
214 break;
215
216 case DBUS_TYPE_DOUBLE:
217 CHECK_FLOAT (object);
218 sprintf (signature, "%c", dtype);
219 break;
220
221 case DBUS_TYPE_STRING:
222 case DBUS_TYPE_OBJECT_PATH:
223 case DBUS_TYPE_SIGNATURE:
224 CHECK_STRING (object);
225 sprintf (signature, "%c", dtype);
226 break;
227
228 case DBUS_TYPE_ARRAY:
229 /* Check that all list elements have the same D-Bus type. For
230 complex element types, we just check the container type, not
231 the whole element's signature. */
232 CHECK_CONS (object);
233
234 /* Type symbol is optional. */
235 if (EQ (QCdbus_type_array, CAR_SAFE (elt)))
236 elt = XD_NEXT_VALUE (elt);
237
238 /* If the array is empty, DBUS_TYPE_STRING is the default
239 element type. */
240 if (NILP (elt))
241 {
242 subtype = DBUS_TYPE_STRING;
243 strcpy (x, DBUS_TYPE_STRING_AS_STRING);
244 }
245 else
246 {
247 subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
248 xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
249 }
250
251 /* If the element type is DBUS_TYPE_SIGNATURE, and this is the
252 only element, the value of this element is used as he array's
253 element signature. */
254 if ((subtype == DBUS_TYPE_SIGNATURE)
255 && STRINGP (CAR_SAFE (XD_NEXT_VALUE (elt)))
256 && NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
257 strcpy (x, SDATA (CAR_SAFE (XD_NEXT_VALUE (elt))));
258
259 while (!NILP (elt))
260 {
261 if (subtype != XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt)))
262 wrong_type_argument (intern ("D-Bus"), CAR_SAFE (elt));
263 elt = CDR_SAFE (XD_NEXT_VALUE (elt));
264 }
265
266 sprintf (signature, "%c%s", dtype, x);
267 break;
268
269 case DBUS_TYPE_VARIANT:
270 /* Check that there is exactly one list element. */
271 CHECK_CONS (object);
272
273 elt = XD_NEXT_VALUE (elt);
274 subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
275 xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
276
277 if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
278 wrong_type_argument (intern ("D-Bus"),
279 CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt))));
280
281 sprintf (signature, "%c", dtype);
282 break;
283
284 case DBUS_TYPE_STRUCT:
285 /* A struct list might contain any number of elements with
286 different types. No further check needed. */
287 CHECK_CONS (object);
288
289 elt = XD_NEXT_VALUE (elt);
290
291 /* Compose the signature from the elements. It is enclosed by
292 parentheses. */
293 sprintf (signature, "%c", DBUS_STRUCT_BEGIN_CHAR );
294 while (!NILP (elt))
295 {
296 subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
297 xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
298 strcat (signature, x);
299 elt = CDR_SAFE (XD_NEXT_VALUE (elt));
300 }
301 sprintf (signature, "%s%c", signature, DBUS_STRUCT_END_CHAR);
302 break;
303
304 case DBUS_TYPE_DICT_ENTRY:
305 /* Check that there are exactly two list elements, and the first
306 one is of basic type. The dictionary entry itself must be an
307 element of an array. */
308 CHECK_CONS (object);
309
310 /* Check the parent object type. */
311 if (parent_type != DBUS_TYPE_ARRAY)
312 wrong_type_argument (intern ("D-Bus"), object);
313
314 /* Compose the signature from the elements. It is enclosed by
315 curly braces. */
316 sprintf (signature, "%c", DBUS_DICT_ENTRY_BEGIN_CHAR);
317
318 /* First element. */
319 elt = XD_NEXT_VALUE (elt);
320 subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
321 xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
322 strcat (signature, x);
323
324 if (!XD_BASIC_DBUS_TYPE (subtype))
325 wrong_type_argument (intern ("D-Bus"), CAR_SAFE (XD_NEXT_VALUE (elt)));
326
327 /* Second element. */
328 elt = CDR_SAFE (XD_NEXT_VALUE (elt));
329 subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
330 xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
331 strcat (signature, x);
332
333 if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
334 wrong_type_argument (intern ("D-Bus"),
335 CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt))));
336
337 /* Closing signature. */
338 sprintf (signature, "%s%c", signature, DBUS_DICT_ENTRY_END_CHAR);
339 break;
340
341 default:
342 wrong_type_argument (intern ("D-Bus"), object);
343 }
344
345 XD_DEBUG_MESSAGE ("%s", signature);
346 }
347
348 /* Append C value, extracted from Lisp OBJECT, to iteration ITER.
349 DTYPE must be a valid DBusType. It is used to convert Lisp
350 objects, being arguments of `dbus-call-method' or
351 `dbus-send-signal', into corresponding C values appended as
352 arguments to a D-Bus message. */
353 void
354 xd_append_arg (dtype, object, iter)
355 unsigned int dtype;
356 Lisp_Object object;
357 DBusMessageIter *iter;
358 {
359 char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
360 DBusMessageIter subiter;
361
362 if (XD_BASIC_DBUS_TYPE (dtype))
363 switch (dtype)
364 {
365 case DBUS_TYPE_BYTE:
366 {
367 unsigned char val = XUINT (object) & 0xFF;
368 XD_DEBUG_MESSAGE ("%c %d", dtype, val);
369 if (!dbus_message_iter_append_basic (iter, dtype, &val))
370 xsignal2 (Qdbus_error,
371 build_string ("Unable to append argument"), object);
372 return;
373 }
374
375 case DBUS_TYPE_BOOLEAN:
376 {
377 dbus_bool_t val = (NILP (object)) ? FALSE : TRUE;
378 XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true");
379 if (!dbus_message_iter_append_basic (iter, dtype, &val))
380 xsignal2 (Qdbus_error,
381 build_string ("Unable to append argument"), object);
382 return;
383 }
384
385 case DBUS_TYPE_INT16:
386 {
387 dbus_int16_t val = XINT (object);
388 XD_DEBUG_MESSAGE ("%c %d", dtype, (int) val);
389 if (!dbus_message_iter_append_basic (iter, dtype, &val))
390 xsignal2 (Qdbus_error,
391 build_string ("Unable to append argument"), object);
392 return;
393 }
394
395 case DBUS_TYPE_UINT16:
396 {
397 dbus_uint16_t val = XUINT (object);
398 XD_DEBUG_MESSAGE ("%c %u", dtype, (unsigned int) val);
399 if (!dbus_message_iter_append_basic (iter, dtype, &val))
400 xsignal2 (Qdbus_error,
401 build_string ("Unable to append argument"), object);
402 return;
403 }
404
405 case DBUS_TYPE_INT32:
406 {
407 dbus_int32_t val = XINT (object);
408 XD_DEBUG_MESSAGE ("%c %d", dtype, val);
409 if (!dbus_message_iter_append_basic (iter, dtype, &val))
410 xsignal2 (Qdbus_error,
411 build_string ("Unable to append argument"), object);
412 return;
413 }
414
415 case DBUS_TYPE_UINT32:
416 {
417 dbus_uint32_t val = XUINT (object);
418 XD_DEBUG_MESSAGE ("%c %u", dtype, val);
419 if (!dbus_message_iter_append_basic (iter, dtype, &val))
420 xsignal2 (Qdbus_error,
421 build_string ("Unable to append argument"), object);
422 return;
423 }
424
425 case DBUS_TYPE_INT64:
426 {
427 dbus_int64_t val = XINT (object);
428 XD_DEBUG_MESSAGE ("%c %d", dtype, (int) val);
429 if (!dbus_message_iter_append_basic (iter, dtype, &val))
430 xsignal2 (Qdbus_error,
431 build_string ("Unable to append argument"), object);
432 return;
433 }
434
435 case DBUS_TYPE_UINT64:
436 {
437 dbus_uint64_t val = XUINT (object);
438 XD_DEBUG_MESSAGE ("%c %u", dtype, (unsigned int) val);
439 if (!dbus_message_iter_append_basic (iter, dtype, &val))
440 xsignal2 (Qdbus_error,
441 build_string ("Unable to append argument"), object);
442 return;
443 }
444
445 case DBUS_TYPE_DOUBLE:
446 XD_DEBUG_MESSAGE ("%c %f", dtype, XFLOAT_DATA (object));
447 if (!dbus_message_iter_append_basic (iter, dtype,
448 &XFLOAT_DATA (object)))
449 xsignal2 (Qdbus_error,
450 build_string ("Unable to append argument"), object);
451 return;
452
453 case DBUS_TYPE_STRING:
454 case DBUS_TYPE_OBJECT_PATH:
455 case DBUS_TYPE_SIGNATURE:
456 {
457 char *val = SDATA (object);
458 XD_DEBUG_MESSAGE ("%c %s", dtype, val);
459 if (!dbus_message_iter_append_basic (iter, dtype, &val))
460 xsignal2 (Qdbus_error,
461 build_string ("Unable to append argument"), object);
462 return;
463 }
464 }
465
466 else /* Compound types. */
467 {
468
469 /* All compound types except array have a type symbol. For
470 array, it is optional. Skip it. */
471 if (!XD_BASIC_DBUS_TYPE (XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object))))
472 object = XD_NEXT_VALUE (object);
473
474 /* Open new subiteration. */
475 switch (dtype)
476 {
477 case DBUS_TYPE_ARRAY:
478 /* An array has only elements of the same type. So it is
479 sufficient to check the first element's signature
480 only. */
481
482 if (NILP (object))
483 /* If the array is empty, DBUS_TYPE_STRING is the default
484 element type. */
485 strcpy (signature, DBUS_TYPE_STRING_AS_STRING);
486
487 else
488 /* If the element type is DBUS_TYPE_SIGNATURE, and this is
489 the only element, the value of this element is used as
490 the array's element signature. */
491 if ((XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object))
492 == DBUS_TYPE_SIGNATURE)
493 && STRINGP (CAR_SAFE (XD_NEXT_VALUE (object)))
494 && NILP (CDR_SAFE (XD_NEXT_VALUE (object))))
495 {
496 strcpy (signature, SDATA (CAR_SAFE (XD_NEXT_VALUE (object))));
497 object = CDR_SAFE (XD_NEXT_VALUE (object));
498 }
499
500 else
501 xd_signature (signature,
502 XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object)),
503 dtype, CAR_SAFE (XD_NEXT_VALUE (object)));
504
505 XD_DEBUG_MESSAGE ("%c %s %s", dtype, signature,
506 SDATA (format2 ("%s", object, Qnil)));
507 if (!dbus_message_iter_open_container (iter, dtype,
508 signature, &subiter))
509 xsignal3 (Qdbus_error,
510 build_string ("Cannot open container"),
511 make_number (dtype), build_string (signature));
512 break;
513
514 case DBUS_TYPE_VARIANT:
515 /* A variant has just one element. */
516 xd_signature (signature, XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object)),
517 dtype, CAR_SAFE (XD_NEXT_VALUE (object)));
518
519 XD_DEBUG_MESSAGE ("%c %s %s", dtype, signature,
520 SDATA (format2 ("%s", object, Qnil)));
521 if (!dbus_message_iter_open_container (iter, dtype,
522 signature, &subiter))
523 xsignal3 (Qdbus_error,
524 build_string ("Cannot open container"),
525 make_number (dtype), build_string (signature));
526 break;
527
528 case DBUS_TYPE_STRUCT:
529 case DBUS_TYPE_DICT_ENTRY:
530 /* These containers do not require a signature. */
531 XD_DEBUG_MESSAGE ("%c %s", dtype,
532 SDATA (format2 ("%s", object, Qnil)));
533 if (!dbus_message_iter_open_container (iter, dtype, NULL, &subiter))
534 xsignal2 (Qdbus_error,
535 build_string ("Cannot open container"),
536 make_number (dtype));
537 break;
538 }
539
540 /* Loop over list elements. */
541 while (!NILP (object))
542 {
543 dtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object));
544 object = XD_NEXT_VALUE (object);
545
546 xd_append_arg (dtype, CAR_SAFE (object), &subiter);
547
548 object = CDR_SAFE (object);
549 }
550
551 /* Close the subiteration. */
552 if (!dbus_message_iter_close_container (iter, &subiter))
553 xsignal2 (Qdbus_error,
554 build_string ("Cannot close container"),
555 make_number (dtype));
556 }
557 }
558
559 /* Retrieve C value from a DBusMessageIter structure ITER, and return
560 a converted Lisp object. The type DTYPE of the argument of the
561 D-Bus message must be a valid DBusType. Compound D-Bus types
562 result always in a Lisp list. */
563 Lisp_Object
564 xd_retrieve_arg (dtype, iter)
565 unsigned int dtype;
566 DBusMessageIter *iter;
567 {
568
569 switch (dtype)
570 {
571 case DBUS_TYPE_BYTE:
572 {
573 unsigned int val;
574 dbus_message_iter_get_basic (iter, &val);
575 val = val & 0xFF;
576 XD_DEBUG_MESSAGE ("%c %d", dtype, val);
577 return make_number (val);
578 }
579
580 case DBUS_TYPE_BOOLEAN:
581 {
582 dbus_bool_t val;
583 dbus_message_iter_get_basic (iter, &val);
584 XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true");
585 return (val == FALSE) ? Qnil : Qt;
586 }
587
588 case DBUS_TYPE_INT16:
589 case DBUS_TYPE_UINT16:
590 {
591 dbus_uint16_t val;
592 dbus_message_iter_get_basic (iter, &val);
593 XD_DEBUG_MESSAGE ("%c %d", dtype, val);
594 return make_number (val);
595 }
596
597 case DBUS_TYPE_INT32:
598 case DBUS_TYPE_UINT32:
599 {
600 /* Assignment to EMACS_INT stops GCC whining about limited
601 range of data type. */
602 dbus_uint32_t val;
603 EMACS_INT val1;
604 dbus_message_iter_get_basic (iter, &val);
605 XD_DEBUG_MESSAGE ("%c %d", dtype, val);
606 val1 = val;
607 return make_fixnum_or_float (val1);
608 }
609
610 case DBUS_TYPE_INT64:
611 case DBUS_TYPE_UINT64:
612 {
613 dbus_uint64_t val;
614 dbus_message_iter_get_basic (iter, &val);
615 XD_DEBUG_MESSAGE ("%c %d", dtype, (int) val);
616 return make_fixnum_or_float (val);
617 }
618
619 case DBUS_TYPE_DOUBLE:
620 {
621 double val;
622 dbus_message_iter_get_basic (iter, &val);
623 XD_DEBUG_MESSAGE ("%c %f", dtype, val);
624 return make_float (val);
625 }
626
627 case DBUS_TYPE_STRING:
628 case DBUS_TYPE_OBJECT_PATH:
629 case DBUS_TYPE_SIGNATURE:
630 {
631 char *val;
632 dbus_message_iter_get_basic (iter, &val);
633 XD_DEBUG_MESSAGE ("%c %s", dtype, val);
634 return build_string (val);
635 }
636
637 case DBUS_TYPE_ARRAY:
638 case DBUS_TYPE_VARIANT:
639 case DBUS_TYPE_STRUCT:
640 case DBUS_TYPE_DICT_ENTRY:
641 {
642 Lisp_Object result;
643 struct gcpro gcpro1;
644 result = Qnil;
645 GCPRO1 (result);
646 DBusMessageIter subiter;
647 int subtype;
648 dbus_message_iter_recurse (iter, &subiter);
649 while ((subtype = dbus_message_iter_get_arg_type (&subiter))
650 != DBUS_TYPE_INVALID)
651 {
652 result = Fcons (xd_retrieve_arg (subtype, &subiter), result);
653 dbus_message_iter_next (&subiter);
654 }
655 XD_DEBUG_MESSAGE ("%c %s", dtype, SDATA (format2 ("%s", result, Qnil)));
656 RETURN_UNGCPRO (Fnreverse (result));
657 }
658
659 default:
660 XD_DEBUG_MESSAGE ("DBusType '%c' not supported", dtype);
661 return Qnil;
662 }
663 }
664
665 /* Initialize D-Bus connection. BUS is a Lisp symbol, either :system
666 or :session. It tells which D-Bus to be initialized. */
667 DBusConnection *
668 xd_initialize (bus)
669 Lisp_Object bus;
670 {
671 DBusConnection *connection;
672 DBusError derror;
673
674 /* Parameter check. */
675 CHECK_SYMBOL (bus);
676 if (!((EQ (bus, QCdbus_system_bus)) || (EQ (bus, QCdbus_session_bus))))
677 xsignal2 (Qdbus_error, build_string ("Wrong bus name"), bus);
678
679 /* Open a connection to the bus. */
680 dbus_error_init (&derror);
681
682 if (EQ (bus, QCdbus_system_bus))
683 connection = dbus_bus_get (DBUS_BUS_SYSTEM, &derror);
684 else
685 connection = dbus_bus_get (DBUS_BUS_SESSION, &derror);
686
687 if (dbus_error_is_set (&derror))
688 XD_ERROR (derror);
689
690 if (connection == NULL)
691 xsignal2 (Qdbus_error, build_string ("No connection"), bus);
692
693 /* Return the result. */
694 return connection;
695 }
696
697 DEFUN ("dbus-get-unique-name", Fdbus_get_unique_name, Sdbus_get_unique_name,
698 1, 1, 0,
699 doc: /* Return the unique name of Emacs registered at D-Bus BUS. */)
700 (bus)
701 Lisp_Object bus;
702 {
703 DBusConnection *connection;
704 const char *name;
705
706 /* Check parameters. */
707 CHECK_SYMBOL (bus);
708
709 /* Open a connection to the bus. */
710 connection = xd_initialize (bus);
711
712 /* Request the name. */
713 name = dbus_bus_get_unique_name (connection);
714 if (name == NULL)
715 xsignal1 (Qdbus_error, build_string ("No unique name available"));
716
717 /* Return. */
718 return build_string (name);
719 }
720
721 DEFUN ("dbus-call-method", Fdbus_call_method, Sdbus_call_method, 5, MANY, 0,
722 doc: /* Call METHOD on the D-Bus BUS.
723
724 BUS is either the symbol `:system' or the symbol `:session'.
725
726 SERVICE is the D-Bus service name to be used. PATH is the D-Bus
727 object path SERVICE is registered at. INTERFACE is an interface
728 offered by SERVICE. It must provide METHOD.
729
730 If the parameter `:timeout' is given, the following integer TIMEOUT
731 specifies the maximun number of milliseconds the method call must
732 return. The default value is 25.000. If the method call doesn't
733 return in time, a D-Bus error is raised.
734
735 All other arguments ARGS are passed to METHOD as arguments. They are
736 converted into D-Bus types via the following rules:
737
738 t and nil => DBUS_TYPE_BOOLEAN
739 number => DBUS_TYPE_UINT32
740 integer => DBUS_TYPE_INT32
741 float => DBUS_TYPE_DOUBLE
742 string => DBUS_TYPE_STRING
743 list => DBUS_TYPE_ARRAY
744
745 All arguments can be preceded by a type symbol. For details about
746 type symbols, see Info node `(dbus)Type Conversion'.
747
748 `dbus-call-method' returns the resulting values of METHOD as a list of
749 Lisp objects. The type conversion happens the other direction as for
750 input arguments. It follows the mapping rules:
751
752 DBUS_TYPE_BOOLEAN => t or nil
753 DBUS_TYPE_BYTE => number
754 DBUS_TYPE_UINT16 => number
755 DBUS_TYPE_INT16 => integer
756 DBUS_TYPE_UINT32 => number or float
757 DBUS_TYPE_INT32 => integer or float
758 DBUS_TYPE_UINT64 => number or float
759 DBUS_TYPE_INT64 => integer or float
760 DBUS_TYPE_DOUBLE => float
761 DBUS_TYPE_STRING => string
762 DBUS_TYPE_OBJECT_PATH => string
763 DBUS_TYPE_SIGNATURE => string
764 DBUS_TYPE_ARRAY => list
765 DBUS_TYPE_VARIANT => list
766 DBUS_TYPE_STRUCT => list
767 DBUS_TYPE_DICT_ENTRY => list
768
769 Example:
770
771 \(dbus-call-method
772 :session "org.gnome.seahorse" "/org/gnome/seahorse/keys/openpgp"
773 "org.gnome.seahorse.Keys" "GetKeyField"
774 "openpgp:657984B8C7A966DD" "simple-name")
775
776 => (t ("Philip R. Zimmermann"))
777
778 If the result of the METHOD call is just one value, the converted Lisp
779 object is returned instead of a list containing this single Lisp object.
780
781 \(dbus-call-method
782 :system "org.freedesktop.Hal" "/org/freedesktop/Hal/devices/computer"
783 "org.freedesktop.Hal.Device" "GetPropertyString"
784 "system.kernel.machine")
785
786 => "i686"
787
788 usage: (dbus-call-method
789 BUS SERVICE PATH INTERFACE METHOD
790 &optional :timeout TIMEOUT &rest ARGS) */)
791 (nargs, args)
792 int nargs;
793 register Lisp_Object *args;
794 {
795 Lisp_Object bus, service, path, interface, method;
796 Lisp_Object result;
797 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
798 DBusConnection *connection;
799 DBusMessage *dmessage;
800 DBusMessage *reply;
801 DBusMessageIter iter;
802 DBusError derror;
803 unsigned int dtype;
804 int timeout = -1;
805 int i = 5;
806 char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
807
808 /* Check parameters. */
809 bus = args[0];
810 service = args[1];
811 path = args[2];
812 interface = args[3];
813 method = args[4];
814
815 CHECK_SYMBOL (bus);
816 CHECK_STRING (service);
817 CHECK_STRING (path);
818 CHECK_STRING (interface);
819 CHECK_STRING (method);
820 GCPRO5 (bus, service, path, interface, method);
821
822 XD_DEBUG_MESSAGE ("%s %s %s %s",
823 SDATA (service),
824 SDATA (path),
825 SDATA (interface),
826 SDATA (method));
827
828 /* Open a connection to the bus. */
829 connection = xd_initialize (bus);
830
831 /* Create the message. */
832 dmessage = dbus_message_new_method_call (SDATA (service),
833 SDATA (path),
834 SDATA (interface),
835 SDATA (method));
836 UNGCPRO;
837 if (dmessage == NULL)
838 xsignal1 (Qdbus_error, build_string ("Unable to create a new message"));
839
840 /* Check for timeout parameter. */
841 if ((i+2 <= nargs) && (EQ ((args[i]), QCdbus_timeout)))
842 {
843 CHECK_NATNUM (args[i+1]);
844 timeout = XUINT (args[i+1]);
845 i = i+2;
846 }
847
848 /* Initialize parameter list of message. */
849 dbus_message_iter_init_append (dmessage, &iter);
850
851 /* Append parameters to the message. */
852 for (; i < nargs; ++i)
853 {
854 dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
855 if (XD_DBUS_TYPE_P (args[i]))
856 {
857 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
858 XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
859 XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-4,
860 SDATA (format2 ("%s", args[i], Qnil)),
861 SDATA (format2 ("%s", args[i+1], Qnil)));
862 ++i;
863 }
864 else
865 {
866 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
867 XD_DEBUG_MESSAGE ("Parameter%d %s", i-4,
868 SDATA (format2 ("%s", args[i], Qnil)));
869 }
870
871 /* Check for valid signature. We use DBUS_TYPE_INVALID as
872 indication that there is no parent type. */
873 xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
874
875 xd_append_arg (dtype, args[i], &iter);
876 }
877
878 /* Send the message. */
879 dbus_error_init (&derror);
880 reply = dbus_connection_send_with_reply_and_block (connection,
881 dmessage,
882 timeout,
883 &derror);
884
885 if (dbus_error_is_set (&derror))
886 XD_ERROR (derror);
887
888 if (reply == NULL)
889 xsignal1 (Qdbus_error, build_string ("No reply"));
890
891 XD_DEBUG_MESSAGE ("Message sent");
892
893 /* Collect the results. */
894 result = Qnil;
895 GCPRO1 (result);
896
897 if (dbus_message_iter_init (reply, &iter))
898 {
899 /* Loop over the parameters of the D-Bus reply message. Construct a
900 Lisp list, which is returned by `dbus-call-method'. */
901 while ((dtype = dbus_message_iter_get_arg_type (&iter))
902 != DBUS_TYPE_INVALID)
903 {
904 result = Fcons (xd_retrieve_arg (dtype, &iter), result);
905 dbus_message_iter_next (&iter);
906 }
907 }
908 else
909 {
910 /* No arguments: just return nil. */
911 }
912
913 /* Cleanup. */
914 dbus_message_unref (dmessage);
915 dbus_message_unref (reply);
916
917 /* Return the result. If there is only one single Lisp object,
918 return it as-it-is, otherwise return the reversed list. */
919 if (XUINT (Flength (result)) == 1)
920 RETURN_UNGCPRO (CAR_SAFE (result));
921 else
922 RETURN_UNGCPRO (Fnreverse (result));
923 }
924
925 DEFUN ("dbus-method-return-internal", Fdbus_method_return_internal,
926 Sdbus_method_return_internal,
927 3, MANY, 0,
928 doc: /* Return for message SERIAL on the D-Bus BUS.
929 This is an internal function, it shall not be used outside dbus.el.
930
931 usage: (dbus-method-return-internal BUS SERIAL SERVICE &rest ARGS) */)
932 (nargs, args)
933 int nargs;
934 register Lisp_Object *args;
935 {
936 Lisp_Object bus, serial, service;
937 struct gcpro gcpro1, gcpro2, gcpro3;
938 DBusConnection *connection;
939 DBusMessage *dmessage;
940 DBusMessageIter iter;
941 unsigned int dtype;
942 int i;
943 char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
944
945 /* Check parameters. */
946 bus = args[0];
947 serial = args[1];
948 service = args[2];
949
950 CHECK_SYMBOL (bus);
951 CHECK_NUMBER (serial);
952 CHECK_STRING (service);
953 GCPRO3 (bus, serial, service);
954
955 XD_DEBUG_MESSAGE ("%d %s ", XUINT (serial), SDATA (service));
956
957 /* Open a connection to the bus. */
958 connection = xd_initialize (bus);
959
960 /* Create the message. */
961 dmessage = dbus_message_new (DBUS_MESSAGE_TYPE_METHOD_RETURN);
962 if ((dmessage == NULL)
963 || (!dbus_message_set_reply_serial (dmessage, XUINT (serial)))
964 || (!dbus_message_set_destination (dmessage, SDATA (service))))
965 {
966 UNGCPRO;
967 xsignal1 (Qdbus_error,
968 build_string ("Unable to create a return message"));
969 }
970
971 UNGCPRO;
972
973 /* Initialize parameter list of message. */
974 dbus_message_iter_init_append (dmessage, &iter);
975
976 /* Append parameters to the message. */
977 for (i = 3; i < nargs; ++i)
978 {
979 dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
980 if (XD_DBUS_TYPE_P (args[i]))
981 {
982 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
983 XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
984 XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-2,
985 SDATA (format2 ("%s", args[i], Qnil)),
986 SDATA (format2 ("%s", args[i+1], Qnil)));
987 ++i;
988 }
989 else
990 {
991 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
992 XD_DEBUG_MESSAGE ("Parameter%d %s", i-2,
993 SDATA (format2 ("%s", args[i], Qnil)));
994 }
995
996 /* Check for valid signature. We use DBUS_TYPE_INVALID as
997 indication that there is no parent type. */
998 xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
999
1000 xd_append_arg (dtype, args[i], &iter);
1001 }
1002
1003 /* Send the message. The message is just added to the outgoing
1004 message queue. */
1005 if (!dbus_connection_send (connection, dmessage, NULL))
1006 xsignal1 (Qdbus_error, build_string ("Cannot send message"));
1007
1008 /* Flush connection to ensure the message is handled. */
1009 dbus_connection_flush (connection);
1010
1011 XD_DEBUG_MESSAGE ("Message sent");
1012
1013 /* Cleanup. */
1014 dbus_message_unref (dmessage);
1015
1016 /* Return. */
1017 return Qt;
1018 }
1019
1020 DEFUN ("dbus-send-signal", Fdbus_send_signal, Sdbus_send_signal, 5, MANY, 0,
1021 doc: /* Send signal SIGNAL on the D-Bus BUS.
1022
1023 BUS is either the symbol `:system' or the symbol `:session'.
1024
1025 SERVICE is the D-Bus service name SIGNAL is sent from. PATH is the
1026 D-Bus object path SERVICE is registered at. INTERFACE is an interface
1027 offered by SERVICE. It must provide signal SIGNAL.
1028
1029 All other arguments ARGS are passed to SIGNAL as arguments. They are
1030 converted into D-Bus types via the following rules:
1031
1032 t and nil => DBUS_TYPE_BOOLEAN
1033 number => DBUS_TYPE_UINT32
1034 integer => DBUS_TYPE_INT32
1035 float => DBUS_TYPE_DOUBLE
1036 string => DBUS_TYPE_STRING
1037 list => DBUS_TYPE_ARRAY
1038
1039 All arguments can be preceded by a type symbol. For details about
1040 type symbols, see Info node `(dbus)Type Conversion'.
1041
1042 Example:
1043
1044 \(dbus-send-signal
1045 :session "org.gnu.Emacs" "/org/gnu/Emacs"
1046 "org.gnu.Emacs.FileManager" "FileModified" "/home/albinus/.emacs")
1047
1048 usage: (dbus-send-signal BUS SERVICE PATH INTERFACE SIGNAL &rest ARGS) */)
1049 (nargs, args)
1050 int nargs;
1051 register Lisp_Object *args;
1052 {
1053 Lisp_Object bus, service, path, interface, signal;
1054 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
1055 DBusConnection *connection;
1056 DBusMessage *dmessage;
1057 DBusMessageIter iter;
1058 unsigned int dtype;
1059 int i;
1060 char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1061
1062 /* Check parameters. */
1063 bus = args[0];
1064 service = args[1];
1065 path = args[2];
1066 interface = args[3];
1067 signal = args[4];
1068
1069 CHECK_SYMBOL (bus);
1070 CHECK_STRING (service);
1071 CHECK_STRING (path);
1072 CHECK_STRING (interface);
1073 CHECK_STRING (signal);
1074 GCPRO5 (bus, service, path, interface, signal);
1075
1076 XD_DEBUG_MESSAGE ("%s %s %s %s",
1077 SDATA (service),
1078 SDATA (path),
1079 SDATA (interface),
1080 SDATA (signal));
1081
1082 /* Open a connection to the bus. */
1083 connection = xd_initialize (bus);
1084
1085 /* Create the message. */
1086 dmessage = dbus_message_new_signal (SDATA (path),
1087 SDATA (interface),
1088 SDATA (signal));
1089 UNGCPRO;
1090 if (dmessage == NULL)
1091 xsignal1 (Qdbus_error, build_string ("Unable to create a new message"));
1092
1093 /* Initialize parameter list of message. */
1094 dbus_message_iter_init_append (dmessage, &iter);
1095
1096 /* Append parameters to the message. */
1097 for (i = 5; i < nargs; ++i)
1098 {
1099 dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1100 if (XD_DBUS_TYPE_P (args[i]))
1101 {
1102 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1103 XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1104 XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-4,
1105 SDATA (format2 ("%s", args[i], Qnil)),
1106 SDATA (format2 ("%s", args[i+1], Qnil)));
1107 ++i;
1108 }
1109 else
1110 {
1111 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1112 XD_DEBUG_MESSAGE ("Parameter%d %s", i-4,
1113 SDATA (format2 ("%s", args[i], Qnil)));
1114 }
1115
1116 /* Check for valid signature. We use DBUS_TYPE_INVALID as
1117 indication that there is no parent type. */
1118 xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1119
1120 xd_append_arg (dtype, args[i], &iter);
1121 }
1122
1123 /* Send the message. The message is just added to the outgoing
1124 message queue. */
1125 if (!dbus_connection_send (connection, dmessage, NULL))
1126 xsignal1 (Qdbus_error, build_string ("Cannot send message"));
1127
1128 /* Flush connection to ensure the message is handled. */
1129 dbus_connection_flush (connection);
1130
1131 XD_DEBUG_MESSAGE ("Signal sent");
1132
1133 /* Cleanup. */
1134 dbus_message_unref (dmessage);
1135
1136 /* Return. */
1137 return Qt;
1138 }
1139
1140 /* Read queued incoming message of the D-Bus BUS. BUS is a Lisp
1141 symbol, either :system or :session. */
1142 Lisp_Object
1143 xd_read_message (bus)
1144 Lisp_Object bus;
1145 {
1146 Lisp_Object args, key, value;
1147 struct gcpro gcpro1;
1148 struct input_event event;
1149 DBusConnection *connection;
1150 DBusMessage *dmessage;
1151 DBusMessageIter iter;
1152 unsigned int dtype;
1153 int mtype;
1154 const char *uname, *path, *interface, *member;
1155
1156 /* Open a connection to the bus. */
1157 connection = xd_initialize (bus);
1158
1159 /* Non blocking read of the next available message. */
1160 dbus_connection_read_write (connection, 0);
1161 dmessage = dbus_connection_pop_message (connection);
1162
1163 /* Return if there is no queued message. */
1164 if (dmessage == NULL)
1165 return Qnil;
1166
1167 /* Collect the parameters. */
1168 args = Qnil;
1169 GCPRO1 (args);
1170
1171 /* Loop over the resulting parameters. Construct a list. */
1172 if (dbus_message_iter_init (dmessage, &iter))
1173 {
1174 while ((dtype = dbus_message_iter_get_arg_type (&iter))
1175 != DBUS_TYPE_INVALID)
1176 {
1177 args = Fcons (xd_retrieve_arg (dtype, &iter), args);
1178 dbus_message_iter_next (&iter);
1179 }
1180 /* The arguments are stored in reverse order. Reorder them. */
1181 args = Fnreverse (args);
1182 }
1183
1184 /* Read message type, unique name, object path, interface and member
1185 from the message. */
1186 mtype = dbus_message_get_type (dmessage);
1187 uname = dbus_message_get_sender (dmessage);
1188 path = dbus_message_get_path (dmessage);
1189 interface = dbus_message_get_interface (dmessage);
1190 member = dbus_message_get_member (dmessage);
1191
1192 /* Vdbus_registered_functions_table requires non-nil interface and member. */
1193 if ((NULL == interface) || (NULL == member))
1194 goto cleanup;
1195
1196 XD_DEBUG_MESSAGE ("Event received: %d %s %s %s %s %s",
1197 mtype, uname, path, interface, member,
1198 SDATA (format2 ("%s", args, Qnil)));
1199
1200 /* Search for a registered function of the message. */
1201 key = list3 (bus, build_string (interface), build_string (member));
1202 value = Fgethash (key, Vdbus_registered_functions_table, Qnil);
1203
1204 /* Loop over the registered functions. Construct an event. */
1205 while (!NILP (value))
1206 {
1207 key = CAR_SAFE (value);
1208 /* key has the structure (UNAME SERVICE PATH HANDLER). */
1209 if (((uname == NULL)
1210 || (NILP (CAR_SAFE (key)))
1211 || (strcmp (uname, SDATA (CAR_SAFE (key))) == 0))
1212 && ((path == NULL)
1213 || (NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1214 || (strcmp (path, SDATA (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1215 == 0))
1216 && (!NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))))))
1217 {
1218 EVENT_INIT (event);
1219 event.kind = DBUS_EVENT;
1220 event.frame_or_window = Qnil;
1221 event.arg = Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))),
1222 args);
1223
1224 /* Add uname, path, interface and member to the event. */
1225 event.arg = Fcons (build_string (member), event.arg);
1226 event.arg = Fcons (build_string (interface), event.arg);
1227 event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
1228 event.arg);
1229 event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
1230 event.arg);
1231
1232 /* Add the message serial if needed, or nil. */
1233 event.arg = Fcons ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL
1234 ? make_number (dbus_message_get_serial (dmessage))
1235 : Qnil),
1236 event.arg);
1237
1238 /* Add the bus symbol to the event. */
1239 event.arg = Fcons (bus, event.arg);
1240
1241 /* Store it into the input event queue. */
1242 kbd_buffer_store_event (&event);
1243 }
1244 value = CDR_SAFE (value);
1245 }
1246
1247 cleanup:
1248 dbus_message_unref (dmessage);
1249 RETURN_UNGCPRO (Qnil);
1250 }
1251
1252 /* Read queued incoming messages from the system and session buses. */
1253 void
1254 xd_read_queued_messages ()
1255 {
1256
1257 /* Vdbus_registered_functions_table will be initialized as hash
1258 table in dbus.el. When this package isn't loaded yet, it doesn't
1259 make sense to handle D-Bus messages. Furthermore, we ignore all
1260 Lisp errors during the call. */
1261 if (HASH_TABLE_P (Vdbus_registered_functions_table))
1262 {
1263 internal_condition_case_1 (xd_read_message, QCdbus_system_bus,
1264 Qerror, Fidentity);
1265 internal_condition_case_1 (xd_read_message, QCdbus_session_bus,
1266 Qerror, Fidentity);
1267 }
1268 }
1269
1270 DEFUN ("dbus-register-signal", Fdbus_register_signal, Sdbus_register_signal,
1271 6, 6, 0,
1272 doc: /* Register for signal SIGNAL on the D-Bus BUS.
1273
1274 BUS is either the symbol `:system' or the symbol `:session'.
1275
1276 SERVICE is the D-Bus service name used by the sending D-Bus object.
1277 It can be either a known name or the unique name of the D-Bus object
1278 sending the signal. When SERVICE is nil, related signals from all
1279 D-Bus objects shall be accepted.
1280
1281 PATH is the D-Bus object path SERVICE is registered. It can also be
1282 nil if the path name of incoming signals shall not be checked.
1283
1284 INTERFACE is an interface offered by SERVICE. It must provide SIGNAL.
1285 HANDLER is a Lisp function to be called when the signal is received.
1286 It must accept as arguments the values SIGNAL is sending. INTERFACE,
1287 SIGNAL and HANDLER must not be nil. Example:
1288
1289 \(defun my-signal-handler (device)
1290 (message "Device %s added" device))
1291
1292 \(dbus-register-signal
1293 :system "org.freedesktop.Hal" "/org/freedesktop/Hal/Manager"
1294 "org.freedesktop.Hal.Manager" "DeviceAdded" 'my-signal-handler)
1295
1296 => ((:system "org.freedesktop.Hal.Manager" "DeviceAdded")
1297 ("org.freedesktop.Hal" "/org/freedesktop/Hal/Manager" my-signal-handler))
1298
1299 `dbus-register-signal' returns an object, which can be used in
1300 `dbus-unregister-object' for removing the registration. */)
1301 (bus, service, path, interface, signal, handler)
1302 Lisp_Object bus, service, path, interface, signal, handler;
1303 {
1304 Lisp_Object uname, key, key1, value;
1305 DBusConnection *connection;
1306 char rule[DBUS_MAXIMUM_MATCH_RULE_LENGTH];
1307 DBusError derror;
1308
1309 /* Check parameters. */
1310 CHECK_SYMBOL (bus);
1311 if (!NILP (service)) CHECK_STRING (service);
1312 if (!NILP (path)) CHECK_STRING (path);
1313 CHECK_STRING (interface);
1314 CHECK_STRING (signal);
1315 if (!FUNCTIONP (handler))
1316 wrong_type_argument (intern ("functionp"), handler);
1317
1318 /* Retrieve unique name of service. If service is a known name, we
1319 will register for the corresponding unique name, if any. Signals
1320 are sent always with the unique name as sender. Note: the unique
1321 name of "org.freedesktop.DBus" is that string itself. */
1322 if ((STRINGP (service))
1323 && (SBYTES (service) > 0)
1324 && (strcmp (SDATA (service), DBUS_SERVICE_DBUS) != 0)
1325 && (strncmp (SDATA (service), ":", 1) != 0))
1326 {
1327 uname = call2 (intern ("dbus-get-name-owner"), bus, service);
1328 /* When there is no unique name, we mark it with an empty
1329 string. */
1330 if (NILP (uname))
1331 uname = build_string ("");
1332 }
1333 else
1334 uname = service;
1335
1336 /* Create a matching rule if the unique name exists (when no
1337 wildcard). */
1338 if (NILP (uname) || (SBYTES (uname) > 0))
1339 {
1340 /* Open a connection to the bus. */
1341 connection = xd_initialize (bus);
1342
1343 /* Create a rule to receive related signals. */
1344 sprintf (rule,
1345 "type='signal',interface='%s',member='%s'",
1346 SDATA (interface),
1347 SDATA (signal));
1348
1349 /* Add unique name and path to the rule if they are non-nil. */
1350 if (!NILP (uname))
1351 sprintf (rule, "%s,sender='%s'", rule, SDATA (uname));
1352
1353 if (!NILP (path))
1354 sprintf (rule, "%s,path='%s'", rule, SDATA (path));
1355
1356 /* Add the rule to the bus. */
1357 dbus_error_init (&derror);
1358 dbus_bus_add_match (connection, rule, &derror);
1359 if (dbus_error_is_set (&derror))
1360 XD_ERROR (derror);
1361
1362 XD_DEBUG_MESSAGE ("Matching rule \"%s\" created", rule);
1363 }
1364
1365 /* Create a hash table entry. */
1366 key = list3 (bus, interface, signal);
1367 key1 = list4 (uname, service, path, handler);
1368 value = Fgethash (key, Vdbus_registered_functions_table, Qnil);
1369
1370 if (NILP (Fmember (key1, value)))
1371 Fputhash (key, Fcons (key1, value), Vdbus_registered_functions_table);
1372
1373 /* Return object. */
1374 return list2 (key, list3 (service, path, handler));
1375 }
1376
1377 DEFUN ("dbus-register-method", Fdbus_register_method, Sdbus_register_method,
1378 6, 6, 0,
1379 doc: /* Register for method METHOD on the D-Bus BUS.
1380
1381 BUS is either the symbol `:system' or the symbol `:session'.
1382
1383 SERVICE is the D-Bus service name of the D-Bus object METHOD is
1384 registered for. It must be a known name.
1385
1386 PATH is the D-Bus object path SERVICE is registered. INTERFACE is the
1387 interface offered by SERVICE. It must provide METHOD. HANDLER is a
1388 Lisp function to be called when a method call is received. It must
1389 accept the input arguments of METHOD. The return value of HANDLER is
1390 used for composing the returning D-Bus message. */)
1391 (bus, service, path, interface, method, handler)
1392 Lisp_Object bus, service, path, interface, method, handler;
1393 {
1394 Lisp_Object key, key1, value;
1395 DBusConnection *connection;
1396 int result;
1397 DBusError derror;
1398
1399 /* Check parameters. */
1400 CHECK_SYMBOL (bus);
1401 CHECK_STRING (service);
1402 CHECK_STRING (path);
1403 CHECK_STRING (interface);
1404 CHECK_STRING (method);
1405 if (!FUNCTIONP (handler))
1406 wrong_type_argument (intern ("functionp"), handler);
1407 /* TODO: We must check for a valid service name, otherwise there is
1408 a segmentation fault. */
1409
1410 /* Open a connection to the bus. */
1411 connection = xd_initialize (bus);
1412
1413 /* Request the known name from the bus. We can ignore the result,
1414 it is set to -1 if there is an error - kind of redundancy. */
1415 dbus_error_init (&derror);
1416 result = dbus_bus_request_name (connection, SDATA (service), 0, &derror);
1417 if (dbus_error_is_set (&derror))
1418 XD_ERROR (derror);
1419
1420 /* Create a hash table entry. */
1421 key = list3 (bus, interface, method);
1422 key1 = list4 (Qnil, service, path, handler);
1423 value = Fgethash (key, Vdbus_registered_functions_table, Qnil);
1424
1425 /* We use nil for the unique name, because the method might be
1426 called from everybody. */
1427 if (NILP (Fmember (key1, value)))
1428 Fputhash (key, Fcons (key1, value), Vdbus_registered_functions_table);
1429
1430 /* Return object. */
1431 return list2 (key, list3 (service, path, handler));
1432 }
1433
1434 \f
1435 void
1436 syms_of_dbusbind ()
1437 {
1438
1439 Qdbus_get_unique_name = intern ("dbus-get-unique-name");
1440 staticpro (&Qdbus_get_unique_name);
1441 defsubr (&Sdbus_get_unique_name);
1442
1443 Qdbus_call_method = intern ("dbus-call-method");
1444 staticpro (&Qdbus_call_method);
1445 defsubr (&Sdbus_call_method);
1446
1447 Qdbus_method_return_internal = intern ("dbus-method-return-internal");
1448 staticpro (&Qdbus_method_return_internal);
1449 defsubr (&Sdbus_method_return_internal);
1450
1451 Qdbus_send_signal = intern ("dbus-send-signal");
1452 staticpro (&Qdbus_send_signal);
1453 defsubr (&Sdbus_send_signal);
1454
1455 Qdbus_register_signal = intern ("dbus-register-signal");
1456 staticpro (&Qdbus_register_signal);
1457 defsubr (&Sdbus_register_signal);
1458
1459 Qdbus_register_method = intern ("dbus-register-method");
1460 staticpro (&Qdbus_register_method);
1461 defsubr (&Sdbus_register_method);
1462
1463 Qdbus_error = intern ("dbus-error");
1464 staticpro (&Qdbus_error);
1465 Fput (Qdbus_error, Qerror_conditions,
1466 list2 (Qdbus_error, Qerror));
1467 Fput (Qdbus_error, Qerror_message,
1468 build_string ("D-Bus error"));
1469
1470 QCdbus_system_bus = intern (":system");
1471 staticpro (&QCdbus_system_bus);
1472
1473 QCdbus_session_bus = intern (":session");
1474 staticpro (&QCdbus_session_bus);
1475
1476 QCdbus_timeout = intern (":timeout");
1477 staticpro (&QCdbus_timeout);
1478
1479 QCdbus_type_byte = intern (":byte");
1480 staticpro (&QCdbus_type_byte);
1481
1482 QCdbus_type_boolean = intern (":boolean");
1483 staticpro (&QCdbus_type_boolean);
1484
1485 QCdbus_type_int16 = intern (":int16");
1486 staticpro (&QCdbus_type_int16);
1487
1488 QCdbus_type_uint16 = intern (":uint16");
1489 staticpro (&QCdbus_type_uint16);
1490
1491 QCdbus_type_int32 = intern (":int32");
1492 staticpro (&QCdbus_type_int32);
1493
1494 QCdbus_type_uint32 = intern (":uint32");
1495 staticpro (&QCdbus_type_uint32);
1496
1497 QCdbus_type_int64 = intern (":int64");
1498 staticpro (&QCdbus_type_int64);
1499
1500 QCdbus_type_uint64 = intern (":uint64");
1501 staticpro (&QCdbus_type_uint64);
1502
1503 QCdbus_type_double = intern (":double");
1504 staticpro (&QCdbus_type_double);
1505
1506 QCdbus_type_string = intern (":string");
1507 staticpro (&QCdbus_type_string);
1508
1509 QCdbus_type_object_path = intern (":object-path");
1510 staticpro (&QCdbus_type_object_path);
1511
1512 QCdbus_type_signature = intern (":signature");
1513 staticpro (&QCdbus_type_signature);
1514
1515 QCdbus_type_array = intern (":array");
1516 staticpro (&QCdbus_type_array);
1517
1518 QCdbus_type_variant = intern (":variant");
1519 staticpro (&QCdbus_type_variant);
1520
1521 QCdbus_type_struct = intern (":struct");
1522 staticpro (&QCdbus_type_struct);
1523
1524 QCdbus_type_dict_entry = intern (":dict-entry");
1525 staticpro (&QCdbus_type_dict_entry);
1526
1527 DEFVAR_LISP ("dbus-registered-functions-table",
1528 &Vdbus_registered_functions_table,
1529 doc: /* Hash table of registered functions for D-Bus.
1530 The key in the hash table is the list (BUS INTERFACE MEMBER). BUS is
1531 either the symbol `:system' or the symbol `:session'. INTERFACE is a
1532 string which denotes a D-Bus interface, and MEMBER, also a string, is
1533 either a method or a signal INTERFACE is offering. All arguments but
1534 BUS must not be nil.
1535
1536 The value in the hash table is a list of quadruple lists
1537 \((UNAME SERVICE PATH HANDLER) (UNAME SERVICE PATH HANDLER) ...).
1538 SERVICE is the service name as registered, UNAME is the corresponding
1539 unique name. PATH is the object path of the sending object. All of
1540 them can be nil, which means a wildcard then. HANDLER is the function
1541 to be called when a D-Bus message, which matches the key criteria,
1542 arrives. */);
1543 /* We initialize Vdbus_registered_functions_table in dbus.el,
1544 because we need to define a hash table function first. */
1545 Vdbus_registered_functions_table = Qnil;
1546
1547 DEFVAR_LISP ("dbus-debug", &Vdbus_debug,
1548 doc: /* If non-nil, debug messages of D-Bus bindings are raised. */);
1549 #ifdef DBUS_DEBUG
1550 Vdbus_debug = Qt;
1551 #else
1552 Vdbus_debug = Qnil;
1553 #endif
1554
1555 Fprovide (intern ("dbusbind"), Qnil);
1556
1557 }
1558
1559 #endif /* HAVE_DBUS */
1560
1561 /* arch-tag: 0e828477-b571-4fe4-b559-5c9211bc14b8
1562 (do not change this comment) */