]> code.delx.au - gnu-emacs/blob - src/dbusbind.c
delx.au / code / gnu-emacs / blob


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