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