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