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