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