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