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