HCoop / bpt / emacs.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
Merge from trunk
[bpt/emacs.git] / src / dbusbind.c
1 /* Elisp bindings for D-Bus.
2 Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
3
4 This file is part of GNU Emacs.
5
6 GNU Emacs is free software: you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation, either version 3 of the License, or
9 (at your option) any later version.
10
11 GNU Emacs is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
15
16 You should have received a copy of the GNU General Public License
17 along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. */
18
19 #include <config.h>
20
21 #ifdef HAVE_DBUS
22 #include <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 /* Return the file descriptor for WATCH, -1 if not found. */
804 static int
805 xd_find_watch_fd (DBusWatch *watch)
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 return fd;
816 }
817
818 /* Prototype. */
819 static void
820 xd_read_queued_messages (int fd, void *data, int for_read);
821
822 /* Start monitoring WATCH for possible I/O. */
823 static dbus_bool_t
824 xd_add_watch (DBusWatch *watch, void *data)
825 {
826 unsigned int flags = dbus_watch_get_flags (watch);
827 int fd = xd_find_watch_fd (watch);
828
829 XD_DEBUG_MESSAGE ("fd %d, write %d, enabled %d",
830 fd, flags & DBUS_WATCH_WRITABLE,
831 dbus_watch_get_enabled (watch));
832
833 if (fd == -1)
834 return FALSE;
835
836 if (dbus_watch_get_enabled (watch))
837 {
838 if (flags & DBUS_WATCH_WRITABLE)
839 add_write_fd (fd, xd_read_queued_messages, data);
840 if (flags & DBUS_WATCH_READABLE)
841 add_read_fd (fd, xd_read_queued_messages, data);
842 }
843 return TRUE;
844 }
845
846 /* Stop monitoring WATCH for possible I/O.
847 DATA is the used bus, either a string or QCdbus_system_bus or
848 QCdbus_session_bus. */
849 static void
850 xd_remove_watch (DBusWatch *watch, void *data)
851 {
852 unsigned int flags = dbus_watch_get_flags (watch);
853 int fd = xd_find_watch_fd (watch);
854
855 XD_DEBUG_MESSAGE ("fd %d", fd);
856
857 if (fd == -1)
858 return;
859
860 /* Unset session environment. */
861 if (data != NULL && data == (void*) XHASH (QCdbus_session_bus))
862 {
863 XD_DEBUG_MESSAGE ("unsetenv DBUS_SESSION_BUS_ADDRESS");
864 unsetenv ("DBUS_SESSION_BUS_ADDRESS");
865 }
866
867 if (flags & DBUS_WATCH_WRITABLE)
868 delete_write_fd (fd);
869 if (flags & DBUS_WATCH_READABLE)
870 delete_read_fd (fd);
871 }
872
873 /* Toggle monitoring WATCH for possible I/O. */
874 static void
875 xd_toggle_watch (DBusWatch *watch, void *data)
876 {
877 if (dbus_watch_get_enabled (watch))
878 xd_add_watch (watch, data);
879 else
880 xd_remove_watch (watch, data);
881 }
882
883 DEFUN ("dbus-init-bus", Fdbus_init_bus, Sdbus_init_bus, 1, 1, 0,
884 doc: /* Initialize connection to D-Bus BUS. */)
885 (Lisp_Object bus)
886 {
887 DBusConnection *connection;
888
889 /* Open a connection to the bus. */
890 connection = xd_initialize (bus, TRUE);
891
892 /* Add the watch functions. We pass also the bus as data, in order
893 to distinguish between the busses in xd_remove_watch. */
894 if (!dbus_connection_set_watch_functions (connection,
895 xd_add_watch,
896 xd_remove_watch,
897 xd_toggle_watch,
898 (void*) XHASH (bus), NULL))
899 XD_SIGNAL1 (build_string ("Cannot add watch functions"));
900
901 /* Add bus to list of registered buses. */
902 Vdbus_registered_buses = Fcons (bus, Vdbus_registered_buses);
903
904 /* Return. */
905 return Qnil;
906 }
907
908 DEFUN ("dbus-close-bus", Fdbus_close_bus, Sdbus_close_bus, 1, 1, 0,
909 doc: /* Close connection to D-Bus BUS. */)
910 (Lisp_Object bus)
911 {
912 DBusConnection *connection;
913
914 /* Open a connection to the bus. */
915 connection = xd_initialize (bus, TRUE);
916
917 /* Decrement reference count to the bus. */
918 dbus_connection_unref (connection);
919
920 /* Remove bus from list of registered buses. */
921 Vdbus_registered_buses = Fdelete (bus, Vdbus_registered_buses);
922
923 /* Return. */
924 return Qnil;
925 }
926
927 DEFUN ("dbus-get-unique-name", Fdbus_get_unique_name, Sdbus_get_unique_name,
928 1, 1, 0,
929 doc: /* Return the unique name of Emacs registered at D-Bus BUS. */)
930 (Lisp_Object bus)
931 {
932 DBusConnection *connection;
933 const char *name;
934
935 /* Open a connection to the bus. */
936 connection = xd_initialize (bus, TRUE);
937
938 /* Request the name. */
939 name = dbus_bus_get_unique_name (connection);
940 if (name == NULL)
941 XD_SIGNAL1 (build_string ("No unique name available"));
942
943 /* Return. */
944 return build_string (name);
945 }
946
947 DEFUN ("dbus-call-method", Fdbus_call_method, Sdbus_call_method, 5, MANY, 0,
948 doc: /* Call METHOD on the D-Bus BUS.
949
950 BUS is either a Lisp symbol, `:system' or `:session', or a string
951 denoting the bus address.
952
953 SERVICE is the D-Bus service name to be used. PATH is the D-Bus
954 object path SERVICE is registered at. INTERFACE is an interface
955 offered by SERVICE. It must provide METHOD.
956
957 If the parameter `:timeout' is given, the following integer TIMEOUT
958 specifies the maximum number of milliseconds the method call must
959 return. The default value is 25,000. If the method call doesn't
960 return in time, a D-Bus error is raised.
961
962 All other arguments ARGS are passed to METHOD as arguments. They are
963 converted into D-Bus types via the following rules:
964
965 t and nil => DBUS_TYPE_BOOLEAN
966 number => DBUS_TYPE_UINT32
967 integer => DBUS_TYPE_INT32
968 float => DBUS_TYPE_DOUBLE
969 string => DBUS_TYPE_STRING
970 list => DBUS_TYPE_ARRAY
971
972 All arguments can be preceded by a type symbol. For details about
973 type symbols, see Info node `(dbus)Type Conversion'.
974
975 `dbus-call-method' returns the resulting values of METHOD as a list of
976 Lisp objects. The type conversion happens the other direction as for
977 input arguments. It follows the mapping rules:
978
979 DBUS_TYPE_BOOLEAN => t or nil
980 DBUS_TYPE_BYTE => number
981 DBUS_TYPE_UINT16 => number
982 DBUS_TYPE_INT16 => integer
983 DBUS_TYPE_UINT32 => number or float
984 DBUS_TYPE_INT32 => integer or float
985 DBUS_TYPE_UINT64 => number or float
986 DBUS_TYPE_INT64 => integer or float
987 DBUS_TYPE_DOUBLE => float
988 DBUS_TYPE_STRING => string
989 DBUS_TYPE_OBJECT_PATH => string
990 DBUS_TYPE_SIGNATURE => string
991 DBUS_TYPE_ARRAY => list
992 DBUS_TYPE_VARIANT => list
993 DBUS_TYPE_STRUCT => list
994 DBUS_TYPE_DICT_ENTRY => list
995
996 Example:
997
998 \(dbus-call-method
999 :session "org.gnome.seahorse" "/org/gnome/seahorse/keys/openpgp"
1000 "org.gnome.seahorse.Keys" "GetKeyField"
1001 "openpgp:657984B8C7A966DD" "simple-name")
1002
1003 => (t ("Philip R. Zimmermann"))
1004
1005 If the result of the METHOD call is just one value, the converted Lisp
1006 object is returned instead of a list containing this single Lisp object.
1007
1008 \(dbus-call-method
1009 :system "org.freedesktop.Hal" "/org/freedesktop/Hal/devices/computer"
1010 "org.freedesktop.Hal.Device" "GetPropertyString"
1011 "system.kernel.machine")
1012
1013 => "i686"
1014
1015 usage: (dbus-call-method BUS SERVICE PATH INTERFACE METHOD &optional :timeout TIMEOUT &rest ARGS) */)
1016 (int nargs, register Lisp_Object *args)
1017 {
1018 Lisp_Object bus, service, path, interface, method;
1019 Lisp_Object result;
1020 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
1021 DBusConnection *connection;
1022 DBusMessage *dmessage;
1023 DBusMessage *reply;
1024 DBusMessageIter iter;
1025 DBusError derror;
1026 unsigned int dtype;
1027 int timeout = -1;
1028 int i = 5;
1029 char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1030
1031 /* Check parameters. */
1032 bus = args[0];
1033 service = args[1];
1034 path = args[2];
1035 interface = args[3];
1036 method = args[4];
1037
1038 CHECK_STRING (service);
1039 CHECK_STRING (path);
1040 CHECK_STRING (interface);
1041 CHECK_STRING (method);
1042 GCPRO5 (bus, service, path, interface, method);
1043
1044 XD_DEBUG_MESSAGE ("%s %s %s %s",
1045 SDATA (service),
1046 SDATA (path),
1047 SDATA (interface),
1048 SDATA (method));
1049
1050 /* Open a connection to the bus. */
1051 connection = xd_initialize (bus, TRUE);
1052
1053 /* Create the message. */
1054 dmessage = dbus_message_new_method_call (SDATA (service),
1055 SDATA (path),
1056 SDATA (interface),
1057 SDATA (method));
1058 UNGCPRO;
1059 if (dmessage == NULL)
1060 XD_SIGNAL1 (build_string ("Unable to create a new message"));
1061
1062 /* Check for timeout parameter. */
1063 if ((i+2 <= nargs) && (EQ ((args[i]), QCdbus_timeout)))
1064 {
1065 CHECK_NATNUM (args[i+1]);
1066 timeout = XUINT (args[i+1]);
1067 i = i+2;
1068 }
1069
1070 /* Initialize parameter list of message. */
1071 dbus_message_iter_init_append (dmessage, &iter);
1072
1073 /* Append parameters to the message. */
1074 for (; i < nargs; ++i)
1075 {
1076 dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1077 if (XD_DBUS_TYPE_P (args[i]))
1078 {
1079 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1080 XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1081 XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-4,
1082 SDATA (format2 ("%s", args[i], Qnil)),
1083 SDATA (format2 ("%s", args[i+1], Qnil)));
1084 ++i;
1085 }
1086 else
1087 {
1088 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1089 XD_DEBUG_MESSAGE ("Parameter%d %s", i-4,
1090 SDATA (format2 ("%s", args[i], Qnil)));
1091 }
1092
1093 /* Check for valid signature. We use DBUS_TYPE_INVALID as
1094 indication that there is no parent type. */
1095 xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1096
1097 xd_append_arg (dtype, args[i], &iter);
1098 }
1099
1100 /* Send the message. */
1101 dbus_error_init (&derror);
1102 reply = dbus_connection_send_with_reply_and_block (connection,
1103 dmessage,
1104 timeout,
1105 &derror);
1106
1107 if (dbus_error_is_set (&derror))
1108 XD_ERROR (derror);
1109
1110 if (reply == NULL)
1111 XD_SIGNAL1 (build_string ("No reply"));
1112
1113 XD_DEBUG_MESSAGE ("Message sent");
1114
1115 /* Collect the results. */
1116 result = Qnil;
1117 GCPRO1 (result);
1118
1119 if (dbus_message_iter_init (reply, &iter))
1120 {
1121 /* Loop over the parameters of the D-Bus reply message. Construct a
1122 Lisp list, which is returned by `dbus-call-method'. */
1123 while ((dtype = dbus_message_iter_get_arg_type (&iter))
1124 != DBUS_TYPE_INVALID)
1125 {
1126 result = Fcons (xd_retrieve_arg (dtype, &iter), result);
1127 dbus_message_iter_next (&iter);
1128 }
1129 }
1130 else
1131 {
1132 /* No arguments: just return nil. */
1133 }
1134
1135 /* Cleanup. */
1136 dbus_error_free (&derror);
1137 dbus_message_unref (dmessage);
1138 dbus_message_unref (reply);
1139
1140 /* Return the result. If there is only one single Lisp object,
1141 return it as-it-is, otherwise return the reversed list. */
1142 if (XUINT (Flength (result)) == 1)
1143 RETURN_UNGCPRO (CAR_SAFE (result));
1144 else
1145 RETURN_UNGCPRO (Fnreverse (result));
1146 }
1147
1148 DEFUN ("dbus-call-method-asynchronously", Fdbus_call_method_asynchronously,
1149 Sdbus_call_method_asynchronously, 6, MANY, 0,
1150 doc: /* Call METHOD on the D-Bus BUS asynchronously.
1151
1152 BUS is either a Lisp symbol, `:system' or `:session', or a string
1153 denoting the bus address.
1154
1155 SERVICE is the D-Bus service name to be used. PATH is the D-Bus
1156 object path SERVICE is registered at. INTERFACE is an interface
1157 offered by SERVICE. It must provide METHOD.
1158
1159 HANDLER is a Lisp function, which is called when the corresponding
1160 return message has arrived. If HANDLER is nil, no return message will
1161 be expected.
1162
1163 If the parameter `:timeout' is given, the following integer TIMEOUT
1164 specifies the maximum number of milliseconds the method call must
1165 return. The default value is 25,000. If the method call doesn't
1166 return in time, a D-Bus error is raised.
1167
1168 All other arguments ARGS are passed to METHOD as arguments. They are
1169 converted into D-Bus types via the following rules:
1170
1171 t and nil => DBUS_TYPE_BOOLEAN
1172 number => DBUS_TYPE_UINT32
1173 integer => DBUS_TYPE_INT32
1174 float => DBUS_TYPE_DOUBLE
1175 string => DBUS_TYPE_STRING
1176 list => DBUS_TYPE_ARRAY
1177
1178 All arguments can be preceded by a type symbol. For details about
1179 type symbols, see Info node `(dbus)Type Conversion'.
1180
1181 Unless HANDLER is nil, the function returns a key into the hash table
1182 `dbus-registered-objects-table'. The corresponding entry in the hash
1183 table is removed, when the return message has been arrived, and
1184 HANDLER is called.
1185
1186 Example:
1187
1188 \(dbus-call-method-asynchronously
1189 :system "org.freedesktop.Hal" "/org/freedesktop/Hal/devices/computer"
1190 "org.freedesktop.Hal.Device" "GetPropertyString" 'message
1191 "system.kernel.machine")
1192
1193 => (:system 2)
1194
1195 -| i686
1196
1197 usage: (dbus-call-method-asynchronously BUS SERVICE PATH INTERFACE METHOD HANDLER &optional :timeout TIMEOUT &rest ARGS) */)
1198 (int nargs, register Lisp_Object *args)
1199 {
1200 Lisp_Object bus, service, path, interface, method, handler;
1201 Lisp_Object result;
1202 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5, gcpro6;
1203 DBusConnection *connection;
1204 DBusMessage *dmessage;
1205 DBusMessageIter iter;
1206 unsigned int dtype;
1207 int timeout = -1;
1208 int i = 6;
1209 char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1210
1211 /* Check parameters. */
1212 bus = args[0];
1213 service = args[1];
1214 path = args[2];
1215 interface = args[3];
1216 method = args[4];
1217 handler = args[5];
1218
1219 CHECK_STRING (service);
1220 CHECK_STRING (path);
1221 CHECK_STRING (interface);
1222 CHECK_STRING (method);
1223 if (!NILP (handler) && !FUNCTIONP (handler))
1224 wrong_type_argument (intern ("functionp"), handler);
1225 GCPRO6 (bus, service, path, interface, method, handler);
1226
1227 XD_DEBUG_MESSAGE ("%s %s %s %s",
1228 SDATA (service),
1229 SDATA (path),
1230 SDATA (interface),
1231 SDATA (method));
1232
1233 /* Open a connection to the bus. */
1234 connection = xd_initialize (bus, TRUE);
1235
1236 /* Create the message. */
1237 dmessage = dbus_message_new_method_call (SDATA (service),
1238 SDATA (path),
1239 SDATA (interface),
1240 SDATA (method));
1241 if (dmessage == NULL)
1242 XD_SIGNAL1 (build_string ("Unable to create a new message"));
1243
1244 /* Check for timeout parameter. */
1245 if ((i+2 <= nargs) && (EQ ((args[i]), QCdbus_timeout)))
1246 {
1247 CHECK_NATNUM (args[i+1]);
1248 timeout = XUINT (args[i+1]);
1249 i = i+2;
1250 }
1251
1252 /* Initialize parameter list of message. */
1253 dbus_message_iter_init_append (dmessage, &iter);
1254
1255 /* Append parameters to the message. */
1256 for (; i < nargs; ++i)
1257 {
1258 dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1259 if (XD_DBUS_TYPE_P (args[i]))
1260 {
1261 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1262 XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1263 XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-4,
1264 SDATA (format2 ("%s", args[i], Qnil)),
1265 SDATA (format2 ("%s", args[i+1], Qnil)));
1266 ++i;
1267 }
1268 else
1269 {
1270 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1271 XD_DEBUG_MESSAGE ("Parameter%d %s", i-4,
1272 SDATA (format2 ("%s", args[i], Qnil)));
1273 }
1274
1275 /* Check for valid signature. We use DBUS_TYPE_INVALID as
1276 indication that there is no parent type. */
1277 xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1278
1279 xd_append_arg (dtype, args[i], &iter);
1280 }
1281
1282 if (!NILP (handler))
1283 {
1284 /* Send the message. The message is just added to the outgoing
1285 message queue. */
1286 if (!dbus_connection_send_with_reply (connection, dmessage,
1287 NULL, timeout))
1288 XD_SIGNAL1 (build_string ("Cannot send message"));
1289
1290 /* The result is the key in Vdbus_registered_objects_table. */
1291 result = (list2 (bus, make_number (dbus_message_get_serial (dmessage))));
1292
1293 /* Create a hash table entry. */
1294 Fputhash (result, handler, Vdbus_registered_objects_table);
1295 }
1296 else
1297 {
1298 /* Send the message. The message is just added to the outgoing
1299 message queue. */
1300 if (!dbus_connection_send (connection, dmessage, NULL))
1301 XD_SIGNAL1 (build_string ("Cannot send message"));
1302
1303 result = Qnil;
1304 }
1305
1306 XD_DEBUG_MESSAGE ("Message sent");
1307
1308 /* Cleanup. */
1309 dbus_message_unref (dmessage);
1310
1311 /* Return the result. */
1312 RETURN_UNGCPRO (result);
1313 }
1314
1315 DEFUN ("dbus-method-return-internal", Fdbus_method_return_internal,
1316 Sdbus_method_return_internal,
1317 3, MANY, 0,
1318 doc: /* Return for message SERIAL on the D-Bus BUS.
1319 This is an internal function, it shall not be used outside dbus.el.
1320
1321 usage: (dbus-method-return-internal BUS SERIAL SERVICE &rest ARGS) */)
1322 (int nargs, register Lisp_Object *args)
1323 {
1324 Lisp_Object bus, serial, service;
1325 struct gcpro gcpro1, gcpro2, gcpro3;
1326 DBusConnection *connection;
1327 DBusMessage *dmessage;
1328 DBusMessageIter iter;
1329 unsigned int dtype;
1330 int i;
1331 char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1332
1333 /* Check parameters. */
1334 bus = args[0];
1335 serial = args[1];
1336 service = args[2];
1337
1338 CHECK_NUMBER (serial);
1339 CHECK_STRING (service);
1340 GCPRO3 (bus, serial, service);
1341
1342 XD_DEBUG_MESSAGE ("%lu %s ", (unsigned long) XUINT (serial), SDATA (service));
1343
1344 /* Open a connection to the bus. */
1345 connection = xd_initialize (bus, TRUE);
1346
1347 /* Create the message. */
1348 dmessage = dbus_message_new (DBUS_MESSAGE_TYPE_METHOD_RETURN);
1349 if ((dmessage == NULL)
1350 || (!dbus_message_set_reply_serial (dmessage, XUINT (serial)))
1351 || (!dbus_message_set_destination (dmessage, SDATA (service))))
1352 {
1353 UNGCPRO;
1354 XD_SIGNAL1 (build_string ("Unable to create a return message"));
1355 }
1356
1357 UNGCPRO;
1358
1359 /* Initialize parameter list of message. */
1360 dbus_message_iter_init_append (dmessage, &iter);
1361
1362 /* Append parameters to the message. */
1363 for (i = 3; i < nargs; ++i)
1364 {
1365 dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1366 if (XD_DBUS_TYPE_P (args[i]))
1367 {
1368 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1369 XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1370 XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-2,
1371 SDATA (format2 ("%s", args[i], Qnil)),
1372 SDATA (format2 ("%s", args[i+1], Qnil)));
1373 ++i;
1374 }
1375 else
1376 {
1377 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1378 XD_DEBUG_MESSAGE ("Parameter%d %s", i-2,
1379 SDATA (format2 ("%s", args[i], Qnil)));
1380 }
1381
1382 /* Check for valid signature. We use DBUS_TYPE_INVALID as
1383 indication that there is no parent type. */
1384 xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1385
1386 xd_append_arg (dtype, args[i], &iter);
1387 }
1388
1389 /* Send the message. The message is just added to the outgoing
1390 message queue. */
1391 if (!dbus_connection_send (connection, dmessage, NULL))
1392 XD_SIGNAL1 (build_string ("Cannot send message"));
1393
1394 XD_DEBUG_MESSAGE ("Message sent");
1395
1396 /* Cleanup. */
1397 dbus_message_unref (dmessage);
1398
1399 /* Return. */
1400 return Qt;
1401 }
1402
1403 DEFUN ("dbus-method-error-internal", Fdbus_method_error_internal,
1404 Sdbus_method_error_internal,
1405 3, MANY, 0,
1406 doc: /* Return error message for message SERIAL on the D-Bus BUS.
1407 This is an internal function, it shall not be used outside dbus.el.
1408
1409 usage: (dbus-method-error-internal BUS SERIAL SERVICE &rest ARGS) */)
1410 (int nargs, register Lisp_Object *args)
1411 {
1412 Lisp_Object bus, serial, service;
1413 struct gcpro gcpro1, gcpro2, gcpro3;
1414 DBusConnection *connection;
1415 DBusMessage *dmessage;
1416 DBusMessageIter iter;
1417 unsigned int dtype;
1418 int i;
1419 char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1420
1421 /* Check parameters. */
1422 bus = args[0];
1423 serial = args[1];
1424 service = args[2];
1425
1426 CHECK_NUMBER (serial);
1427 CHECK_STRING (service);
1428 GCPRO3 (bus, serial, service);
1429
1430 XD_DEBUG_MESSAGE ("%lu %s ", (unsigned long) XUINT (serial), SDATA (service));
1431
1432 /* Open a connection to the bus. */
1433 connection = xd_initialize (bus, TRUE);
1434
1435 /* Create the message. */
1436 dmessage = dbus_message_new (DBUS_MESSAGE_TYPE_ERROR);
1437 if ((dmessage == NULL)
1438 || (!dbus_message_set_error_name (dmessage, DBUS_ERROR_FAILED))
1439 || (!dbus_message_set_reply_serial (dmessage, XUINT (serial)))
1440 || (!dbus_message_set_destination (dmessage, SDATA (service))))
1441 {
1442 UNGCPRO;
1443 XD_SIGNAL1 (build_string ("Unable to create a error message"));
1444 }
1445
1446 UNGCPRO;
1447
1448 /* Initialize parameter list of message. */
1449 dbus_message_iter_init_append (dmessage, &iter);
1450
1451 /* Append parameters to the message. */
1452 for (i = 3; i < nargs; ++i)
1453 {
1454 dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1455 if (XD_DBUS_TYPE_P (args[i]))
1456 {
1457 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1458 XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1459 XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-2,
1460 SDATA (format2 ("%s", args[i], Qnil)),
1461 SDATA (format2 ("%s", args[i+1], Qnil)));
1462 ++i;
1463 }
1464 else
1465 {
1466 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1467 XD_DEBUG_MESSAGE ("Parameter%d %s", i-2,
1468 SDATA (format2 ("%s", args[i], Qnil)));
1469 }
1470
1471 /* Check for valid signature. We use DBUS_TYPE_INVALID as
1472 indication that there is no parent type. */
1473 xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1474
1475 xd_append_arg (dtype, args[i], &iter);
1476 }
1477
1478 /* Send the message. The message is just added to the outgoing
1479 message queue. */
1480 if (!dbus_connection_send (connection, dmessage, NULL))
1481 XD_SIGNAL1 (build_string ("Cannot send message"));
1482
1483 XD_DEBUG_MESSAGE ("Message sent");
1484
1485 /* Cleanup. */
1486 dbus_message_unref (dmessage);
1487
1488 /* Return. */
1489 return Qt;
1490 }
1491
1492 DEFUN ("dbus-send-signal", Fdbus_send_signal, Sdbus_send_signal, 5, MANY, 0,
1493 doc: /* Send signal SIGNAL on the D-Bus BUS.
1494
1495 BUS is either a Lisp symbol, `:system' or `:session', or a string
1496 denoting the bus address.
1497
1498 SERVICE is the D-Bus service name SIGNAL is sent from. PATH is the
1499 D-Bus object path SERVICE is registered at. INTERFACE is an interface
1500 offered by SERVICE. It must provide signal SIGNAL.
1501
1502 All other arguments ARGS are passed to SIGNAL as arguments. They are
1503 converted into D-Bus types via the following rules:
1504
1505 t and nil => DBUS_TYPE_BOOLEAN
1506 number => DBUS_TYPE_UINT32
1507 integer => DBUS_TYPE_INT32
1508 float => DBUS_TYPE_DOUBLE
1509 string => DBUS_TYPE_STRING
1510 list => DBUS_TYPE_ARRAY
1511
1512 All arguments can be preceded by a type symbol. For details about
1513 type symbols, see Info node `(dbus)Type Conversion'.
1514
1515 Example:
1516
1517 \(dbus-send-signal
1518 :session "org.gnu.Emacs" "/org/gnu/Emacs"
1519 "org.gnu.Emacs.FileManager" "FileModified" "/home/albinus/.emacs")
1520
1521 usage: (dbus-send-signal BUS SERVICE PATH INTERFACE SIGNAL &rest ARGS) */)
1522 (int nargs, register Lisp_Object *args)
1523 {
1524 Lisp_Object bus, service, path, interface, signal;
1525 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
1526 DBusConnection *connection;
1527 DBusMessage *dmessage;
1528 DBusMessageIter iter;
1529 unsigned int dtype;
1530 int i;
1531 char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1532
1533 /* Check parameters. */
1534 bus = args[0];
1535 service = args[1];
1536 path = args[2];
1537 interface = args[3];
1538 signal = args[4];
1539
1540 CHECK_STRING (service);
1541 CHECK_STRING (path);
1542 CHECK_STRING (interface);
1543 CHECK_STRING (signal);
1544 GCPRO5 (bus, service, path, interface, signal);
1545
1546 XD_DEBUG_MESSAGE ("%s %s %s %s",
1547 SDATA (service),
1548 SDATA (path),
1549 SDATA (interface),
1550 SDATA (signal));
1551
1552 /* Open a connection to the bus. */
1553 connection = xd_initialize (bus, TRUE);
1554
1555 /* Create the message. */
1556 dmessage = dbus_message_new_signal (SDATA (path),
1557 SDATA (interface),
1558 SDATA (signal));
1559 UNGCPRO;
1560 if (dmessage == NULL)
1561 XD_SIGNAL1 (build_string ("Unable to create a new message"));
1562
1563 /* Initialize parameter list of message. */
1564 dbus_message_iter_init_append (dmessage, &iter);
1565
1566 /* Append parameters to the message. */
1567 for (i = 5; i < nargs; ++i)
1568 {
1569 dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1570 if (XD_DBUS_TYPE_P (args[i]))
1571 {
1572 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1573 XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1574 XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-4,
1575 SDATA (format2 ("%s", args[i], Qnil)),
1576 SDATA (format2 ("%s", args[i+1], Qnil)));
1577 ++i;
1578 }
1579 else
1580 {
1581 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1582 XD_DEBUG_MESSAGE ("Parameter%d %s", i-4,
1583 SDATA (format2 ("%s", args[i], Qnil)));
1584 }
1585
1586 /* Check for valid signature. We use DBUS_TYPE_INVALID as
1587 indication that there is no parent type. */
1588 xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1589
1590 xd_append_arg (dtype, args[i], &iter);
1591 }
1592
1593 /* Send the message. The message is just added to the outgoing
1594 message queue. */
1595 if (!dbus_connection_send (connection, dmessage, NULL))
1596 XD_SIGNAL1 (build_string ("Cannot send message"));
1597
1598 XD_DEBUG_MESSAGE ("Signal sent");
1599
1600 /* Cleanup. */
1601 dbus_message_unref (dmessage);
1602
1603 /* Return. */
1604 return Qt;
1605 }
1606
1607 /* Read one queued incoming message of the D-Bus BUS.
1608 BUS is either a Lisp symbol, :system or :session, or a string denoting
1609 the bus address. */
1610 static void
1611 xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
1612 {
1613 Lisp_Object args, key, value;
1614 struct gcpro gcpro1;
1615 struct input_event event;
1616 DBusMessage *dmessage;
1617 DBusMessageIter iter;
1618 unsigned int dtype;
1619 int mtype, serial;
1620 const char *uname, *path, *interface, *member;
1621
1622 dmessage = dbus_connection_pop_message (connection);
1623
1624 /* Return if there is no queued message. */
1625 if (dmessage == NULL)
1626 return;
1627
1628 /* Collect the parameters. */
1629 args = Qnil;
1630 GCPRO1 (args);
1631
1632 /* Loop over the resulting parameters. Construct a list. */
1633 if (dbus_message_iter_init (dmessage, &iter))
1634 {
1635 while ((dtype = dbus_message_iter_get_arg_type (&iter))
1636 != DBUS_TYPE_INVALID)
1637 {
1638 args = Fcons (xd_retrieve_arg (dtype, &iter), args);
1639 dbus_message_iter_next (&iter);
1640 }
1641 /* The arguments are stored in reverse order. Reorder them. */
1642 args = Fnreverse (args);
1643 }
1644
1645 /* Read message type, message serial, unique name, object path,
1646 interface and member from the message. */
1647 mtype = dbus_message_get_type (dmessage);
1648 serial =
1649 ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1650 || (mtype == DBUS_MESSAGE_TYPE_ERROR))
1651 ? dbus_message_get_reply_serial (dmessage)
1652 : dbus_message_get_serial (dmessage);
1653 uname = dbus_message_get_sender (dmessage);
1654 path = dbus_message_get_path (dmessage);
1655 interface = dbus_message_get_interface (dmessage);
1656 member = dbus_message_get_member (dmessage);
1657
1658 XD_DEBUG_MESSAGE ("Event received: %s %d %s %s %s %s %s",
1659 (mtype == DBUS_MESSAGE_TYPE_INVALID)
1660 ? "DBUS_MESSAGE_TYPE_INVALID"
1661 : (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1662 ? "DBUS_MESSAGE_TYPE_METHOD_CALL"
1663 : (mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1664 ? "DBUS_MESSAGE_TYPE_METHOD_RETURN"
1665 : (mtype == DBUS_MESSAGE_TYPE_ERROR)
1666 ? "DBUS_MESSAGE_TYPE_ERROR"
1667 : "DBUS_MESSAGE_TYPE_SIGNAL",
1668 serial, uname, path, interface, member,
1669 SDATA (format2 ("%s", args, Qnil)));
1670
1671 if ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1672 || (mtype == DBUS_MESSAGE_TYPE_ERROR))
1673 {
1674 /* Search for a registered function of the message. */
1675 key = list2 (bus, make_number (serial));
1676 value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1677
1678 /* There shall be exactly one entry. Construct an event. */
1679 if (NILP (value))
1680 goto cleanup;
1681
1682 /* Remove the entry. */
1683 Fremhash (key, Vdbus_registered_objects_table);
1684
1685 /* Construct an event. */
1686 EVENT_INIT (event);
1687 event.kind = DBUS_EVENT;
1688 event.frame_or_window = Qnil;
1689 event.arg = Fcons (value, args);
1690 }
1691
1692 else /* (mtype != DBUS_MESSAGE_TYPE_METHOD_RETURN) */
1693 {
1694 /* Vdbus_registered_objects_table requires non-nil interface and
1695 member. */
1696 if ((interface == NULL) || (member == NULL))
1697 goto cleanup;
1698
1699 /* Search for a registered function of the message. */
1700 key = list3 (bus, build_string (interface), build_string (member));
1701 value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1702
1703 /* Loop over the registered functions. Construct an event. */
1704 while (!NILP (value))
1705 {
1706 key = CAR_SAFE (value);
1707 /* key has the structure (UNAME SERVICE PATH HANDLER). */
1708 if (((uname == NULL)
1709 || (NILP (CAR_SAFE (key)))
1710 || (strcmp (uname, SDATA (CAR_SAFE (key))) == 0))
1711 && ((path == NULL)
1712 || (NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1713 || (strcmp (path,
1714 SDATA (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1715 == 0))
1716 && (!NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))))))
1717 {
1718 EVENT_INIT (event);
1719 event.kind = DBUS_EVENT;
1720 event.frame_or_window = Qnil;
1721 event.arg = Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))),
1722 args);
1723 break;
1724 }
1725 value = CDR_SAFE (value);
1726 }
1727
1728 if (NILP (value))
1729 goto cleanup;
1730 }
1731
1732 /* Add type, serial, uname, path, interface and member to the event. */
1733 event.arg = Fcons ((member == NULL ? Qnil : build_string (member)),
1734 event.arg);
1735 event.arg = Fcons ((interface == NULL ? Qnil : build_string (interface)),
1736 event.arg);
1737 event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
1738 event.arg);
1739 event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
1740 event.arg);
1741 event.arg = Fcons (make_number (serial), event.arg);
1742 event.arg = Fcons (make_number (mtype), event.arg);
1743
1744 /* Add the bus symbol to the event. */
1745 event.arg = Fcons (bus, event.arg);
1746
1747 /* Store it into the input event queue. */
1748 kbd_buffer_store_event (&event);
1749
1750 XD_DEBUG_MESSAGE ("Event stored: %s",
1751 SDATA (format2 ("%s", event.arg, Qnil)));
1752
1753 /* Cleanup. */
1754 cleanup:
1755 dbus_message_unref (dmessage);
1756
1757 UNGCPRO;
1758 }
1759
1760 /* Read queued incoming messages of the D-Bus BUS.
1761 BUS is either a Lisp symbol, :system or :session, or a string denoting
1762 the bus address. */
1763 static Lisp_Object
1764 xd_read_message (Lisp_Object bus)
1765 {
1766 /* Open a connection to the bus. */
1767 DBusConnection *connection = xd_initialize (bus, TRUE);
1768
1769 /* Non blocking read of the next available message. */
1770 dbus_connection_read_write (connection, 0);
1771
1772 while (dbus_connection_get_dispatch_status (connection)
1773 != DBUS_DISPATCH_COMPLETE)
1774 xd_read_message_1 (connection, bus);
1775 return Qnil;
1776 }
1777
1778 /* Callback called when something is ready to read or write. */
1779 static void
1780 xd_read_queued_messages (int fd, void *data, int for_read)
1781 {
1782 Lisp_Object busp = Vdbus_registered_buses;
1783 Lisp_Object bus = Qnil;
1784
1785 /* Find bus related to fd. */
1786 if (data != NULL)
1787 while (!NILP (busp))
1788 {
1789 if (data == (void*) XHASH (CAR_SAFE (busp)))
1790 bus = CAR_SAFE (busp);
1791 busp = CDR_SAFE (busp);
1792 }
1793
1794 if (NILP(bus))
1795 return;
1796
1797 /* We ignore all Lisp errors during the call. */
1798 xd_in_read_queued_messages = 1;
1799 internal_catch (Qdbus_error, xd_read_message, bus);
1800 xd_in_read_queued_messages = 0;
1801 }
1802
1803 DEFUN ("dbus-register-signal", Fdbus_register_signal, Sdbus_register_signal,
1804 6, MANY, 0,
1805 doc: /* Register for signal SIGNAL on the D-Bus BUS.
1806
1807 BUS is either a Lisp symbol, `:system' or `:session', or a string
1808 denoting the bus address.
1809
1810 SERVICE is the D-Bus service name used by the sending D-Bus object.
1811 It can be either a known name or the unique name of the D-Bus object
1812 sending the signal. When SERVICE is nil, related signals from all
1813 D-Bus objects shall be accepted.
1814
1815 PATH is the D-Bus object path SERVICE is registered. It can also be
1816 nil if the path name of incoming signals shall not be checked.
1817
1818 INTERFACE is an interface offered by SERVICE. It must provide SIGNAL.
1819 HANDLER is a Lisp function to be called when the signal is received.
1820 It must accept as arguments the values SIGNAL is sending.
1821
1822 All other arguments ARGS, if specified, must be strings. They stand
1823 for the respective arguments of the signal in their order, and are
1824 used for filtering as well. A nil argument might be used to preserve
1825 the order.
1826
1827 INTERFACE, SIGNAL and HANDLER must not be nil. Example:
1828
1829 \(defun my-signal-handler (device)
1830 (message "Device %s added" device))
1831
1832 \(dbus-register-signal
1833 :system "org.freedesktop.Hal" "/org/freedesktop/Hal/Manager"
1834 "org.freedesktop.Hal.Manager" "DeviceAdded" 'my-signal-handler)
1835
1836 => ((:system "org.freedesktop.Hal.Manager" "DeviceAdded")
1837 ("org.freedesktop.Hal" "/org/freedesktop/Hal/Manager" my-signal-handler))
1838
1839 `dbus-register-signal' returns an object, which can be used in
1840 `dbus-unregister-object' for removing the registration.
1841
1842 usage: (dbus-register-signal BUS SERVICE PATH INTERFACE SIGNAL HANDLER &rest ARGS) */)
1843 (int nargs, register Lisp_Object *args)
1844 {
1845 Lisp_Object bus, service, path, interface, signal, handler;
1846 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5, gcpro6;
1847 Lisp_Object uname, key, key1, value;
1848 DBusConnection *connection;
1849 int i;
1850 char rule[DBUS_MAXIMUM_MATCH_RULE_LENGTH];
1851 char x[DBUS_MAXIMUM_MATCH_RULE_LENGTH];
1852 DBusError derror;
1853
1854 /* Check parameters. */
1855 bus = args[0];
1856 service = args[1];
1857 path = args[2];
1858 interface = args[3];
1859 signal = args[4];
1860 handler = args[5];
1861
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 /* Retrieve unique name of service. If service is a known name, we
1871 will register for the corresponding unique name, if any. Signals
1872 are sent always with the unique name as sender. Note: the unique
1873 name of "org.freedesktop.DBus" is that string itself. */
1874 if ((STRINGP (service))
1875 && (SBYTES (service) > 0)
1876 && (strcmp (SDATA (service), DBUS_SERVICE_DBUS) != 0)
1877 && (strncmp (SDATA (service), ":", 1) != 0))
1878 {
1879 uname = call2 (intern ("dbus-get-name-owner"), bus, service);
1880 /* When there is no unique name, we mark it with an empty
1881 string. */
1882 if (NILP (uname))
1883 uname = empty_unibyte_string;
1884 }
1885 else
1886 uname = service;
1887
1888 /* Create a matching rule if the unique name exists (when no
1889 wildcard). */
1890 if (NILP (uname) || (SBYTES (uname) > 0))
1891 {
1892 /* Open a connection to the bus. */
1893 connection = xd_initialize (bus, TRUE);
1894
1895 /* Create a rule to receive related signals. */
1896 sprintf (rule,
1897 "type='signal',interface='%s',member='%s'",
1898 SDATA (interface),
1899 SDATA (signal));
1900
1901 /* Add unique name and path to the rule if they are non-nil. */
1902 if (!NILP (uname))
1903 {
1904 sprintf (x, ",sender='%s'", SDATA (uname));
1905 strcat (rule, x);
1906 }
1907
1908 if (!NILP (path))
1909 {
1910 sprintf (x, ",path='%s'", SDATA (path));
1911 strcat (rule, x);
1912 }
1913
1914 /* Add arguments to the rule if they are non-nil. */
1915 for (i = 6; i < nargs; ++i)
1916 if (!NILP (args[i]))
1917 {
1918 CHECK_STRING (args[i]);
1919 sprintf (x, ",arg%d='%s'", i-6, SDATA (args[i]));
1920 strcat (rule, x);
1921 }
1922
1923 /* Add the rule to the bus. */
1924 dbus_error_init (&derror);
1925 dbus_bus_add_match (connection, rule, &derror);
1926 if (dbus_error_is_set (&derror))
1927 {
1928 UNGCPRO;
1929 XD_ERROR (derror);
1930 }
1931
1932 /* Cleanup. */
1933 dbus_error_free (&derror);
1934
1935 XD_DEBUG_MESSAGE ("Matching rule \"%s\" created", rule);
1936 }
1937
1938 /* Create a hash table entry. */
1939 key = list3 (bus, interface, signal);
1940 key1 = list4 (uname, service, path, handler);
1941 value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1942
1943 if (NILP (Fmember (key1, value)))
1944 Fputhash (key, Fcons (key1, value), Vdbus_registered_objects_table);
1945
1946 /* Return object. */
1947 RETURN_UNGCPRO (list2 (key, list3 (service, path, handler)));
1948 }
1949
1950 DEFUN ("dbus-register-method", Fdbus_register_method, Sdbus_register_method,
1951 6, 6, 0,
1952 doc: /* Register for method METHOD on the D-Bus BUS.
1953
1954 BUS is either a Lisp symbol, `:system' or `:session', or a string
1955 denoting the bus address.
1956
1957 SERVICE is the D-Bus service name of the D-Bus object METHOD is
1958 registered for. It must be a known name.
1959
1960 PATH is the D-Bus object path SERVICE is registered. INTERFACE is the
1961 interface offered by SERVICE. It must provide METHOD. HANDLER is a
1962 Lisp function to be called when a method call is received. It must
1963 accept the input arguments of METHOD. The return value of HANDLER is
1964 used for composing the returning D-Bus message. */)
1965 (Lisp_Object bus, Lisp_Object service, Lisp_Object path, Lisp_Object interface, Lisp_Object method, Lisp_Object handler)
1966 {
1967 Lisp_Object key, key1, value;
1968 DBusConnection *connection;
1969 int result;
1970 DBusError derror;
1971
1972 /* Check parameters. */
1973 CHECK_STRING (service);
1974 CHECK_STRING (path);
1975 CHECK_STRING (interface);
1976 CHECK_STRING (method);
1977 if (!FUNCTIONP (handler))
1978 wrong_type_argument (intern ("functionp"), handler);
1979 /* TODO: We must check for a valid service name, otherwise there is
1980 a segmentation fault. */
1981
1982 /* Open a connection to the bus. */
1983 connection = xd_initialize (bus, TRUE);
1984
1985 /* Request the known name from the bus. We can ignore the result,
1986 it is set to -1 if there is an error - kind of redundancy. */
1987 dbus_error_init (&derror);
1988 result = dbus_bus_request_name (connection, SDATA (service), 0, &derror);
1989 if (dbus_error_is_set (&derror))
1990 XD_ERROR (derror);
1991
1992 /* Create a hash table entry. We use nil for the unique name,
1993 because the method might be called from anybody. */
1994 key = list3 (bus, interface, method);
1995 key1 = list4 (Qnil, service, path, handler);
1996 value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1997
1998 if (NILP (Fmember (key1, value)))
1999 Fputhash (key, Fcons (key1, value), Vdbus_registered_objects_table);
2000
2001 /* Cleanup. */
2002 dbus_error_free (&derror);
2003
2004 /* Return object. */
2005 return list2 (key, list3 (service, path, handler));
2006 }
2007
2008 \f
2009 void
2010 syms_of_dbusbind (void)
2011 {
2012
2013 Qdbus_init_bus = intern_c_string ("dbus-init-bus");
2014 staticpro (&Qdbus_init_bus);
2015 defsubr (&Sdbus_init_bus);
2016
2017 Qdbus_close_bus = intern_c_string ("dbus-close-bus");
2018 staticpro (&Qdbus_close_bus);
2019 defsubr (&Sdbus_close_bus);
2020
2021 Qdbus_get_unique_name = intern_c_string ("dbus-get-unique-name");
2022 staticpro (&Qdbus_get_unique_name);
2023 defsubr (&Sdbus_get_unique_name);
2024
2025 Qdbus_call_method = intern_c_string ("dbus-call-method");
2026 staticpro (&Qdbus_call_method);
2027 defsubr (&Sdbus_call_method);
2028
2029 Qdbus_call_method_asynchronously = intern_c_string ("dbus-call-method-asynchronously");
2030 staticpro (&Qdbus_call_method_asynchronously);
2031 defsubr (&Sdbus_call_method_asynchronously);
2032
2033 Qdbus_method_return_internal = intern_c_string ("dbus-method-return-internal");
2034 staticpro (&Qdbus_method_return_internal);
2035 defsubr (&Sdbus_method_return_internal);
2036
2037 Qdbus_method_error_internal = intern_c_string ("dbus-method-error-internal");
2038 staticpro (&Qdbus_method_error_internal);
2039 defsubr (&Sdbus_method_error_internal);
2040
2041 Qdbus_send_signal = intern_c_string ("dbus-send-signal");
2042 staticpro (&Qdbus_send_signal);
2043 defsubr (&Sdbus_send_signal);
2044
2045 Qdbus_register_signal = intern_c_string ("dbus-register-signal");
2046 staticpro (&Qdbus_register_signal);
2047 defsubr (&Sdbus_register_signal);
2048
2049 Qdbus_register_method = intern_c_string ("dbus-register-method");
2050 staticpro (&Qdbus_register_method);
2051 defsubr (&Sdbus_register_method);
2052
2053 Qdbus_error = intern_c_string ("dbus-error");
2054 staticpro (&Qdbus_error);
2055 Fput (Qdbus_error, Qerror_conditions,
2056 list2 (Qdbus_error, Qerror));
2057 Fput (Qdbus_error, Qerror_message,
2058 make_pure_c_string ("D-Bus error"));
2059
2060 QCdbus_system_bus = intern_c_string (":system");
2061 staticpro (&QCdbus_system_bus);
2062
2063 QCdbus_session_bus = intern_c_string (":session");
2064 staticpro (&QCdbus_session_bus);
2065
2066 QCdbus_timeout = intern_c_string (":timeout");
2067 staticpro (&QCdbus_timeout);
2068
2069 QCdbus_type_byte = intern_c_string (":byte");
2070 staticpro (&QCdbus_type_byte);
2071
2072 QCdbus_type_boolean = intern_c_string (":boolean");
2073 staticpro (&QCdbus_type_boolean);
2074
2075 QCdbus_type_int16 = intern_c_string (":int16");
2076 staticpro (&QCdbus_type_int16);
2077
2078 QCdbus_type_uint16 = intern_c_string (":uint16");
2079 staticpro (&QCdbus_type_uint16);
2080
2081 QCdbus_type_int32 = intern_c_string (":int32");
2082 staticpro (&QCdbus_type_int32);
2083
2084 QCdbus_type_uint32 = intern_c_string (":uint32");
2085 staticpro (&QCdbus_type_uint32);
2086
2087 QCdbus_type_int64 = intern_c_string (":int64");
2088 staticpro (&QCdbus_type_int64);
2089
2090 QCdbus_type_uint64 = intern_c_string (":uint64");
2091 staticpro (&QCdbus_type_uint64);
2092
2093 QCdbus_type_double = intern_c_string (":double");
2094 staticpro (&QCdbus_type_double);
2095
2096 QCdbus_type_string = intern_c_string (":string");
2097 staticpro (&QCdbus_type_string);
2098
2099 QCdbus_type_object_path = intern_c_string (":object-path");
2100 staticpro (&QCdbus_type_object_path);
2101
2102 QCdbus_type_signature = intern_c_string (":signature");
2103 staticpro (&QCdbus_type_signature);
2104
2105 QCdbus_type_array = intern_c_string (":array");
2106 staticpro (&QCdbus_type_array);
2107
2108 QCdbus_type_variant = intern_c_string (":variant");
2109 staticpro (&QCdbus_type_variant);
2110
2111 QCdbus_type_struct = intern_c_string (":struct");
2112 staticpro (&QCdbus_type_struct);
2113
2114 QCdbus_type_dict_entry = intern_c_string (":dict-entry");
2115 staticpro (&QCdbus_type_dict_entry);
2116
2117 DEFVAR_LISP ("dbus-registered-buses",
2118 &Vdbus_registered_buses,
2119 doc: /* List of D-Bus buses we are polling for messages. */);
2120 Vdbus_registered_buses = Qnil;
2121
2122 DEFVAR_LISP ("dbus-registered-objects-table",
2123 &Vdbus_registered_objects_table,
2124 doc: /* Hash table of registered functions for D-Bus.
2125
2126 There are two different uses of the hash table: for accessing
2127 registered interfaces properties, targeted by signals or method calls,
2128 and for calling handlers in case of non-blocking method call returns.
2129
2130 In the first case, the key in the hash table is the list (BUS
2131 INTERFACE MEMBER). BUS is either a Lisp symbol, `:system' or
2132 `:session', or a string denoting the bus address. INTERFACE is a
2133 string which denotes a D-Bus interface, and MEMBER, also a string, is
2134 either a method, a signal or a property INTERFACE is offering. All
2135 arguments but BUS must not be nil.
2136
2137 The value in the hash table is a list of quadruple lists
2138 \((UNAME SERVICE PATH OBJECT) (UNAME SERVICE PATH OBJECT) ...).
2139 SERVICE is the service name as registered, UNAME is the corresponding
2140 unique name. In case of registered methods and properties, UNAME is
2141 nil. PATH is the object path of the sending object. All of them can
2142 be nil, which means a wildcard then. OBJECT is either the handler to
2143 be called when a D-Bus message, which matches the key criteria,
2144 arrives (methods and signals), or a cons cell containing the value of
2145 the property.
2146
2147 In the second case, the key in the hash table is the list (BUS
2148 SERIAL). BUS is either a Lisp symbol, `:system' or `:session', or a
2149 string denoting the bus address. SERIAL is the serial number of the
2150 non-blocking method call, a reply is expected. Both arguments must
2151 not be nil. The value in the hash table is HANDLER, the function to
2152 be called when the D-Bus reply message arrives. */);
2153 {
2154 Lisp_Object args[2];
2155 args[0] = QCtest;
2156 args[1] = Qequal;
2157 Vdbus_registered_objects_table = Fmake_hash_table (2, args);
2158 }
2159
2160 DEFVAR_LISP ("dbus-debug", &Vdbus_debug,
2161 doc: /* If non-nil, debug messages of D-Bus bindings are raised. */);
2162 #ifdef DBUS_DEBUG
2163 Vdbus_debug = Qt;
2164 /* We can also set environment DBUS_VERBOSE=1 in order to see more
2165 traces. */
2166 #else
2167 Vdbus_debug = Qnil;
2168 /* We do not want to abort. */
2169 setenv ("DBUS_FATAL_WARNINGS", "0", 1);
2170 #endif
2171
2172 Fprovide (intern_c_string ("dbusbind"), Qnil);
2173
2174 }
2175
2176 #endif /* HAVE_DBUS */
2177
2178 /* arch-tag: 0e828477-b571-4fe4-b559-5c9211bc14b8
2179 (do not change this comment) */
Unnamed repository; edit this file 'description' to name the repository.