Address some compilation warnings.
[emacs.git] / src / dbusbind.c
blobbe1b89095efa285e3b75ec15d2ef95e888d33ffd
1 /* Elisp bindings for D-Bus.
2 Copyright (C) 2007-2015 Free Software Foundation, Inc.
4 This file is part of GNU Emacs.
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.
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.
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/>. */
19 #include <config.h>
21 #ifdef HAVE_DBUS
22 #include <stdio.h>
23 #include <dbus/dbus.h>
25 #include "lisp.h"
26 #include "frame.h"
27 #include "termhooks.h"
28 #include "keyboard.h"
29 #include "process.h"
31 #ifndef DBUS_NUM_MESSAGE_TYPES
32 #define DBUS_NUM_MESSAGE_TYPES 5
33 #endif
36 /* Some platforms define the symbol "interface", but we want to use it
37 * as a variable name below. */
39 #ifdef interface
40 #undef interface
41 #endif
44 /* Alist of D-Bus buses we are polling for messages.
45 The key is the symbol or string of the bus, and the value is the
46 connection address. */
47 static Lisp_Object xd_registered_buses;
49 /* Whether we are reading a D-Bus event. */
50 static bool xd_in_read_queued_messages = 0;
53 /* We use "xd_" and "XD_" as prefix for all internal symbols, because
54 we don't want to poison other namespaces with "dbus_". */
56 /* Raise a signal. If we are reading events, we cannot signal; we
57 throw to xd_read_queued_messages then. */
58 #define XD_SIGNAL1(arg) \
59 do { \
60 if (xd_in_read_queued_messages) \
61 Fthrow (Qdbus_error, Qnil); \
62 else \
63 xsignal1 (Qdbus_error, arg); \
64 } while (0)
66 #define XD_SIGNAL2(arg1, arg2) \
67 do { \
68 if (xd_in_read_queued_messages) \
69 Fthrow (Qdbus_error, Qnil); \
70 else \
71 xsignal2 (Qdbus_error, arg1, arg2); \
72 } while (0)
74 #define XD_SIGNAL3(arg1, arg2, arg3) \
75 do { \
76 if (xd_in_read_queued_messages) \
77 Fthrow (Qdbus_error, Qnil); \
78 else \
79 xsignal3 (Qdbus_error, arg1, arg2, arg3); \
80 } while (0)
82 /* Raise a Lisp error from a D-Bus ERROR. */
83 #define XD_ERROR(error) \
84 do { \
85 /* Remove the trailing newline. */ \
86 char const *mess = error.message; \
87 char const *nl = strchr (mess, '\n'); \
88 Lisp_Object err = make_string (mess, nl ? nl - mess : strlen (mess)); \
89 dbus_error_free (&error); \
90 XD_SIGNAL1 (err); \
91 } while (0)
93 /* Macros for debugging. In order to enable them, build with
94 "env MYCPPFLAGS='-DDBUS_DEBUG -Wall' make". */
95 #ifdef DBUS_DEBUG
96 #define XD_DEBUG_MESSAGE(...) \
97 do { \
98 char s[1024]; \
99 snprintf (s, sizeof s, __VA_ARGS__); \
100 if (!noninteractive) \
101 printf ("%s: %s\n", __func__, s); \
102 message ("%s: %s", __func__, s); \
103 } while (0)
104 #define XD_DEBUG_VALID_LISP_OBJECT_P(object) \
105 do { \
106 if (!valid_lisp_object_p (object)) \
108 XD_DEBUG_MESSAGE ("%d Assertion failure", __LINE__); \
109 XD_SIGNAL1 (build_string ("Assertion failure")); \
111 } while (0)
113 #else /* !DBUS_DEBUG */
114 # define XD_DEBUG_MESSAGE(...) \
115 do { \
116 if (!NILP (Vdbus_debug)) \
118 char s[1024]; \
119 snprintf (s, sizeof s, __VA_ARGS__); \
120 message ("%s: %s", __func__, s); \
122 } while (0)
123 # define XD_DEBUG_VALID_LISP_OBJECT_P(object)
124 #endif
126 /* Check whether TYPE is a basic DBusType. */
127 #ifdef HAVE_DBUS_TYPE_IS_VALID
128 #define XD_BASIC_DBUS_TYPE(type) \
129 (dbus_type_is_valid (type) && dbus_type_is_basic (type))
130 #else
131 #ifdef DBUS_TYPE_UNIX_FD
132 #define XD_BASIC_DBUS_TYPE(type) \
133 ((type == DBUS_TYPE_BYTE) \
134 || (type == DBUS_TYPE_BOOLEAN) \
135 || (type == DBUS_TYPE_INT16) \
136 || (type == DBUS_TYPE_UINT16) \
137 || (type == DBUS_TYPE_INT32) \
138 || (type == DBUS_TYPE_UINT32) \
139 || (type == DBUS_TYPE_INT64) \
140 || (type == DBUS_TYPE_UINT64) \
141 || (type == DBUS_TYPE_DOUBLE) \
142 || (type == DBUS_TYPE_STRING) \
143 || (type == DBUS_TYPE_OBJECT_PATH) \
144 || (type == DBUS_TYPE_SIGNATURE) \
145 || (type == DBUS_TYPE_UNIX_FD))
146 #else
147 #define XD_BASIC_DBUS_TYPE(type) \
148 ((type == DBUS_TYPE_BYTE) \
149 || (type == DBUS_TYPE_BOOLEAN) \
150 || (type == DBUS_TYPE_INT16) \
151 || (type == DBUS_TYPE_UINT16) \
152 || (type == DBUS_TYPE_INT32) \
153 || (type == DBUS_TYPE_UINT32) \
154 || (type == DBUS_TYPE_INT64) \
155 || (type == DBUS_TYPE_UINT64) \
156 || (type == DBUS_TYPE_DOUBLE) \
157 || (type == DBUS_TYPE_STRING) \
158 || (type == DBUS_TYPE_OBJECT_PATH) \
159 || (type == DBUS_TYPE_SIGNATURE))
160 #endif
161 #endif
163 /* This was a macro. On Solaris 2.11 it was said to compile for
164 hours, when optimization is enabled. So we have transferred it into
165 a function. */
166 /* Determine the DBusType of a given Lisp symbol. OBJECT must be one
167 of the predefined D-Bus type symbols. */
168 static int
169 xd_symbol_to_dbus_type (Lisp_Object object)
171 return
172 ((EQ (object, QCdbus_type_byte)) ? DBUS_TYPE_BYTE
173 : (EQ (object, QCdbus_type_boolean)) ? DBUS_TYPE_BOOLEAN
174 : (EQ (object, QCdbus_type_int16)) ? DBUS_TYPE_INT16
175 : (EQ (object, QCdbus_type_uint16)) ? DBUS_TYPE_UINT16
176 : (EQ (object, QCdbus_type_int32)) ? DBUS_TYPE_INT32
177 : (EQ (object, QCdbus_type_uint32)) ? DBUS_TYPE_UINT32
178 : (EQ (object, QCdbus_type_int64)) ? DBUS_TYPE_INT64
179 : (EQ (object, QCdbus_type_uint64)) ? DBUS_TYPE_UINT64
180 : (EQ (object, QCdbus_type_double)) ? DBUS_TYPE_DOUBLE
181 : (EQ (object, QCdbus_type_string)) ? DBUS_TYPE_STRING
182 : (EQ (object, QCdbus_type_object_path)) ? DBUS_TYPE_OBJECT_PATH
183 : (EQ (object, QCdbus_type_signature)) ? DBUS_TYPE_SIGNATURE
184 #ifdef DBUS_TYPE_UNIX_FD
185 : (EQ (object, QCdbus_type_unix_fd)) ? DBUS_TYPE_UNIX_FD
186 #endif
187 : (EQ (object, QCdbus_type_array)) ? DBUS_TYPE_ARRAY
188 : (EQ (object, QCdbus_type_variant)) ? DBUS_TYPE_VARIANT
189 : (EQ (object, QCdbus_type_struct)) ? DBUS_TYPE_STRUCT
190 : (EQ (object, QCdbus_type_dict_entry)) ? DBUS_TYPE_DICT_ENTRY
191 : DBUS_TYPE_INVALID);
194 /* Check whether a Lisp symbol is a predefined D-Bus type symbol. */
195 #define XD_DBUS_TYPE_P(object) \
196 (SYMBOLP (object) && ((xd_symbol_to_dbus_type (object) != DBUS_TYPE_INVALID)))
198 /* Determine the DBusType of a given Lisp OBJECT. It is used to
199 convert Lisp objects, being arguments of `dbus-call-method' or
200 `dbus-send-signal', into corresponding C values appended as
201 arguments to a D-Bus message. */
202 #define XD_OBJECT_TO_DBUS_TYPE(object) \
203 ((EQ (object, Qt) || EQ (object, Qnil)) ? DBUS_TYPE_BOOLEAN \
204 : (NATNUMP (object)) ? DBUS_TYPE_UINT32 \
205 : (INTEGERP (object)) ? DBUS_TYPE_INT32 \
206 : (FLOATP (object)) ? DBUS_TYPE_DOUBLE \
207 : (STRINGP (object)) ? DBUS_TYPE_STRING \
208 : (XD_DBUS_TYPE_P (object)) ? xd_symbol_to_dbus_type (object) \
209 : (CONSP (object)) \
210 ? ((XD_DBUS_TYPE_P (CAR_SAFE (object))) \
211 ? ((XD_BASIC_DBUS_TYPE (xd_symbol_to_dbus_type (CAR_SAFE (object)))) \
212 ? DBUS_TYPE_ARRAY \
213 : xd_symbol_to_dbus_type (CAR_SAFE (object))) \
214 : DBUS_TYPE_ARRAY) \
215 : DBUS_TYPE_INVALID)
217 /* Return a list pointer which does not have a Lisp symbol as car. */
218 #define XD_NEXT_VALUE(object) \
219 ((XD_DBUS_TYPE_P (CAR_SAFE (object))) ? CDR_SAFE (object) : object)
221 /* Transform the message type to its string representation for debug
222 messages. */
223 #define XD_MESSAGE_TYPE_TO_STRING(mtype) \
224 ((mtype == DBUS_MESSAGE_TYPE_INVALID) \
225 ? "DBUS_MESSAGE_TYPE_INVALID" \
226 : (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL) \
227 ? "DBUS_MESSAGE_TYPE_METHOD_CALL" \
228 : (mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN) \
229 ? "DBUS_MESSAGE_TYPE_METHOD_RETURN" \
230 : (mtype == DBUS_MESSAGE_TYPE_ERROR) \
231 ? "DBUS_MESSAGE_TYPE_ERROR" \
232 : "DBUS_MESSAGE_TYPE_SIGNAL")
234 /* Transform the object to its string representation for debug
235 messages. */
236 static char *
237 XD_OBJECT_TO_STRING (Lisp_Object object)
239 AUTO_STRING (format, "%s");
240 return SSDATA (CALLN (Fformat, format, object));
243 #define XD_DBUS_VALIDATE_BUS_ADDRESS(bus) \
244 do { \
245 char const *session_bus_address = getenv ("DBUS_SESSION_BUS_ADDRESS"); \
246 if (STRINGP (bus)) \
248 DBusAddressEntry **entries; \
249 int len; \
250 DBusError derror; \
251 dbus_error_init (&derror); \
252 if (!dbus_parse_address (SSDATA (bus), &entries, &len, &derror)) \
253 XD_ERROR (derror); \
254 /* Cleanup. */ \
255 dbus_error_free (&derror); \
256 dbus_address_entries_free (entries); \
257 /* Canonicalize session bus address. */ \
258 if ((session_bus_address != NULL) \
259 && (!NILP (Fstring_equal \
260 (bus, build_string (session_bus_address))))) \
261 bus = QCdbus_session_bus; \
264 else \
266 CHECK_SYMBOL (bus); \
267 if (!(EQ (bus, QCdbus_system_bus) || EQ (bus, QCdbus_session_bus))) \
268 XD_SIGNAL2 (build_string ("Wrong bus name"), bus); \
269 /* We do not want to have an autolaunch for the session bus. */ \
270 if (EQ (bus, QCdbus_session_bus) && session_bus_address == NULL) \
271 XD_SIGNAL2 (build_string ("No connection to bus"), bus); \
273 } while (0)
275 #if (HAVE_DBUS_VALIDATE_BUS_NAME || HAVE_DBUS_VALIDATE_PATH \
276 || HAVE_DBUS_VALIDATE_INTERFACE || HAVE_DBUS_VALIDATE_MEMBER)
277 #define XD_DBUS_VALIDATE_OBJECT(object, func) \
278 do { \
279 if (!NILP (object)) \
281 DBusError derror; \
282 CHECK_STRING (object); \
283 dbus_error_init (&derror); \
284 if (!func (SSDATA (object), &derror)) \
285 XD_ERROR (derror); \
286 /* Cleanup. */ \
287 dbus_error_free (&derror); \
289 } while (0)
290 #endif
292 #if HAVE_DBUS_VALIDATE_BUS_NAME
293 #define XD_DBUS_VALIDATE_BUS_NAME(bus_name) \
294 XD_DBUS_VALIDATE_OBJECT(bus_name, dbus_validate_bus_name);
295 #else
296 #define XD_DBUS_VALIDATE_BUS_NAME(bus_name) \
297 if (!NILP (bus_name)) CHECK_STRING (bus_name);
298 #endif
300 #if HAVE_DBUS_VALIDATE_PATH
301 #define XD_DBUS_VALIDATE_PATH(path) \
302 XD_DBUS_VALIDATE_OBJECT(path, dbus_validate_path);
303 #else
304 #define XD_DBUS_VALIDATE_PATH(path) \
305 if (!NILP (path)) CHECK_STRING (path);
306 #endif
308 #if HAVE_DBUS_VALIDATE_INTERFACE
309 #define XD_DBUS_VALIDATE_INTERFACE(interface) \
310 XD_DBUS_VALIDATE_OBJECT(interface, dbus_validate_interface);
311 #else
312 #define XD_DBUS_VALIDATE_INTERFACE(interface) \
313 if (!NILP (interface)) CHECK_STRING (interface);
314 #endif
316 #if HAVE_DBUS_VALIDATE_MEMBER
317 #define XD_DBUS_VALIDATE_MEMBER(member) \
318 XD_DBUS_VALIDATE_OBJECT(member, dbus_validate_member);
319 #else
320 #define XD_DBUS_VALIDATE_MEMBER(member) \
321 if (!NILP (member)) CHECK_STRING (member);
322 #endif
324 /* Append to SIGNATURE a copy of X, making sure SIGNATURE does
325 not become too long. */
326 static void
327 xd_signature_cat (char *signature, char const *x)
329 ptrdiff_t siglen = strlen (signature);
330 ptrdiff_t xlen = strlen (x);
331 if (DBUS_MAXIMUM_SIGNATURE_LENGTH - xlen <= siglen)
332 string_overflow ();
333 strcpy (signature + siglen, x);
336 /* Compute SIGNATURE of OBJECT. It must have a form that it can be
337 used in dbus_message_iter_open_container. DTYPE is the DBusType
338 the object is related to. It is passed as argument, because it
339 cannot be detected in basic type objects, when they are preceded by
340 a type symbol. PARENT_TYPE is the DBusType of a container this
341 signature is embedded, or DBUS_TYPE_INVALID. It is needed for the
342 check that DBUS_TYPE_DICT_ENTRY occurs only as array element. */
343 static void
344 xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object)
346 int subtype;
347 Lisp_Object elt;
348 char const *subsig;
349 int subsiglen;
350 char x[DBUS_MAXIMUM_SIGNATURE_LENGTH];
352 elt = object;
354 switch (dtype)
356 case DBUS_TYPE_BYTE:
357 case DBUS_TYPE_UINT16:
358 CHECK_NATNUM (object);
359 sprintf (signature, "%c", dtype);
360 break;
362 case DBUS_TYPE_BOOLEAN:
363 if (!EQ (object, Qt) && !EQ (object, Qnil))
364 wrong_type_argument (intern ("booleanp"), object);
365 sprintf (signature, "%c", dtype);
366 break;
368 case DBUS_TYPE_INT16:
369 CHECK_NUMBER (object);
370 sprintf (signature, "%c", dtype);
371 break;
373 case DBUS_TYPE_UINT32:
374 case DBUS_TYPE_UINT64:
375 #ifdef DBUS_TYPE_UNIX_FD
376 case DBUS_TYPE_UNIX_FD:
377 #endif
378 case DBUS_TYPE_INT32:
379 case DBUS_TYPE_INT64:
380 case DBUS_TYPE_DOUBLE:
381 CHECK_NUMBER_OR_FLOAT (object);
382 sprintf (signature, "%c", dtype);
383 break;
385 case DBUS_TYPE_STRING:
386 case DBUS_TYPE_OBJECT_PATH:
387 case DBUS_TYPE_SIGNATURE:
388 CHECK_STRING (object);
389 sprintf (signature, "%c", dtype);
390 break;
392 case DBUS_TYPE_ARRAY:
393 /* Check that all list elements have the same D-Bus type. For
394 complex element types, we just check the container type, not
395 the whole element's signature. */
396 CHECK_CONS (object);
398 /* Type symbol is optional. */
399 if (EQ (QCdbus_type_array, CAR_SAFE (elt)))
400 elt = XD_NEXT_VALUE (elt);
402 /* If the array is empty, DBUS_TYPE_STRING is the default
403 element type. */
404 if (NILP (elt))
406 subtype = DBUS_TYPE_STRING;
407 subsig = DBUS_TYPE_STRING_AS_STRING;
409 else
411 subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
412 xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
413 subsig = x;
416 /* If the element type is DBUS_TYPE_SIGNATURE, and this is the
417 only element, the value of this element is used as the
418 array's element signature. */
419 if ((subtype == DBUS_TYPE_SIGNATURE)
420 && STRINGP (CAR_SAFE (XD_NEXT_VALUE (elt)))
421 && NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
422 subsig = SSDATA (CAR_SAFE (XD_NEXT_VALUE (elt)));
424 while (!NILP (elt))
426 if (subtype != XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt)))
427 wrong_type_argument (intern ("D-Bus"), CAR_SAFE (elt));
428 elt = CDR_SAFE (XD_NEXT_VALUE (elt));
431 subsiglen = snprintf (signature, DBUS_MAXIMUM_SIGNATURE_LENGTH,
432 "%c%s", dtype, subsig);
433 if (! (0 <= subsiglen && subsiglen < DBUS_MAXIMUM_SIGNATURE_LENGTH))
434 string_overflow ();
435 break;
437 case DBUS_TYPE_VARIANT:
438 /* Check that there is exactly one list element. */
439 CHECK_CONS (object);
441 elt = XD_NEXT_VALUE (elt);
442 subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
443 xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
445 if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
446 wrong_type_argument (intern ("D-Bus"),
447 CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt))));
449 sprintf (signature, "%c", dtype);
450 break;
452 case DBUS_TYPE_STRUCT:
453 /* A struct list might contain any number of elements with
454 different types. No further check needed. */
455 CHECK_CONS (object);
457 elt = XD_NEXT_VALUE (elt);
459 /* Compose the signature from the elements. It is enclosed by
460 parentheses. */
461 sprintf (signature, "%c", DBUS_STRUCT_BEGIN_CHAR );
462 while (!NILP (elt))
464 subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
465 xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
466 xd_signature_cat (signature, x);
467 elt = CDR_SAFE (XD_NEXT_VALUE (elt));
469 xd_signature_cat (signature, DBUS_STRUCT_END_CHAR_AS_STRING);
470 break;
472 case DBUS_TYPE_DICT_ENTRY:
473 /* Check that there are exactly two list elements, and the first
474 one is of basic type. The dictionary entry itself must be an
475 element of an array. */
476 CHECK_CONS (object);
478 /* Check the parent object type. */
479 if (parent_type != DBUS_TYPE_ARRAY)
480 wrong_type_argument (intern ("D-Bus"), object);
482 /* Compose the signature from the elements. It is enclosed by
483 curly braces. */
484 sprintf (signature, "%c", DBUS_DICT_ENTRY_BEGIN_CHAR);
486 /* First element. */
487 elt = XD_NEXT_VALUE (elt);
488 subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
489 xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
490 xd_signature_cat (signature, x);
492 if (!XD_BASIC_DBUS_TYPE (subtype))
493 wrong_type_argument (intern ("D-Bus"), CAR_SAFE (XD_NEXT_VALUE (elt)));
495 /* Second element. */
496 elt = CDR_SAFE (XD_NEXT_VALUE (elt));
497 subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
498 xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
499 xd_signature_cat (signature, x);
501 if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
502 wrong_type_argument (intern ("D-Bus"),
503 CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt))));
505 /* Closing signature. */
506 xd_signature_cat (signature, DBUS_DICT_ENTRY_END_CHAR_AS_STRING);
507 break;
509 default:
510 wrong_type_argument (intern ("D-Bus"), object);
513 XD_DEBUG_MESSAGE ("%s", signature);
516 /* Convert X to a signed integer with bounds LO and HI. */
517 static intmax_t
518 xd_extract_signed (Lisp_Object x, intmax_t lo, intmax_t hi)
520 CHECK_NUMBER_OR_FLOAT (x);
521 if (INTEGERP (x))
523 if (lo <= XINT (x) && XINT (x) <= hi)
524 return XINT (x);
526 else
528 double d = XFLOAT_DATA (x);
529 if (lo <= d && d <= hi)
531 intmax_t n = d;
532 if (n == d)
533 return n;
536 if (xd_in_read_queued_messages)
537 Fthrow (Qdbus_error, Qnil);
538 else
539 args_out_of_range_3 (x,
540 make_fixnum_or_float (lo),
541 make_fixnum_or_float (hi));
544 /* Convert X to an unsigned integer with bounds 0 and HI. */
545 static uintmax_t
546 xd_extract_unsigned (Lisp_Object x, uintmax_t hi)
548 CHECK_NUMBER_OR_FLOAT (x);
549 if (INTEGERP (x))
551 if (0 <= XINT (x) && XINT (x) <= hi)
552 return XINT (x);
554 else
556 double d = XFLOAT_DATA (x);
557 if (0 <= d && d <= hi)
559 uintmax_t n = d;
560 if (n == d)
561 return n;
564 if (xd_in_read_queued_messages)
565 Fthrow (Qdbus_error, Qnil);
566 else
567 args_out_of_range_3 (x, make_number (0), make_fixnum_or_float (hi));
570 /* Append C value, extracted from Lisp OBJECT, to iteration ITER.
571 DTYPE must be a valid DBusType. It is used to convert Lisp
572 objects, being arguments of `dbus-call-method' or
573 `dbus-send-signal', into corresponding C values appended as
574 arguments to a D-Bus message. */
575 static void
576 xd_append_arg (int dtype, Lisp_Object object, DBusMessageIter *iter)
578 char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
579 DBusMessageIter subiter;
581 if (XD_BASIC_DBUS_TYPE (dtype))
582 switch (dtype)
584 case DBUS_TYPE_BYTE:
585 CHECK_NATNUM (object);
587 unsigned char val = XFASTINT (object) & 0xFF;
588 XD_DEBUG_MESSAGE ("%c %u", dtype, val);
589 if (!dbus_message_iter_append_basic (iter, dtype, &val))
590 XD_SIGNAL2 (build_string ("Unable to append argument"), object);
591 return;
594 case DBUS_TYPE_BOOLEAN:
596 dbus_bool_t val = (NILP (object)) ? FALSE : TRUE;
597 XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true");
598 if (!dbus_message_iter_append_basic (iter, dtype, &val))
599 XD_SIGNAL2 (build_string ("Unable to append argument"), object);
600 return;
603 case DBUS_TYPE_INT16:
605 dbus_int16_t val =
606 xd_extract_signed (object,
607 TYPE_MINIMUM (dbus_int16_t),
608 TYPE_MAXIMUM (dbus_int16_t));
609 int pval = val;
610 XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
611 if (!dbus_message_iter_append_basic (iter, dtype, &val))
612 XD_SIGNAL2 (build_string ("Unable to append argument"), object);
613 return;
616 case DBUS_TYPE_UINT16:
618 dbus_uint16_t val =
619 xd_extract_unsigned (object,
620 TYPE_MAXIMUM (dbus_uint16_t));
621 unsigned int pval = val;
622 XD_DEBUG_MESSAGE ("%c %u", dtype, pval);
623 if (!dbus_message_iter_append_basic (iter, dtype, &val))
624 XD_SIGNAL2 (build_string ("Unable to append argument"), object);
625 return;
628 case DBUS_TYPE_INT32:
630 dbus_int32_t val =
631 xd_extract_signed (object,
632 TYPE_MINIMUM (dbus_int32_t),
633 TYPE_MAXIMUM (dbus_int32_t));
634 int pval = val;
635 XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
636 if (!dbus_message_iter_append_basic (iter, dtype, &val))
637 XD_SIGNAL2 (build_string ("Unable to append argument"), object);
638 return;
641 case DBUS_TYPE_UINT32:
642 #ifdef DBUS_TYPE_UNIX_FD
643 case DBUS_TYPE_UNIX_FD:
644 #endif
646 dbus_uint32_t val =
647 xd_extract_unsigned (object,
648 TYPE_MAXIMUM (dbus_uint32_t));
649 unsigned int pval = val;
650 XD_DEBUG_MESSAGE ("%c %u", dtype, pval);
651 if (!dbus_message_iter_append_basic (iter, dtype, &val))
652 XD_SIGNAL2 (build_string ("Unable to append argument"), object);
653 return;
656 case DBUS_TYPE_INT64:
658 dbus_int64_t val =
659 xd_extract_signed (object,
660 TYPE_MINIMUM (dbus_int64_t),
661 TYPE_MAXIMUM (dbus_int64_t));
662 printmax_t pval = val;
663 XD_DEBUG_MESSAGE ("%c %"pMd, dtype, pval);
664 if (!dbus_message_iter_append_basic (iter, dtype, &val))
665 XD_SIGNAL2 (build_string ("Unable to append argument"), object);
666 return;
669 case DBUS_TYPE_UINT64:
671 dbus_uint64_t val =
672 xd_extract_unsigned (object,
673 TYPE_MAXIMUM (dbus_uint64_t));
674 uprintmax_t pval = val;
675 XD_DEBUG_MESSAGE ("%c %"pMu, dtype, pval);
676 if (!dbus_message_iter_append_basic (iter, dtype, &val))
677 XD_SIGNAL2 (build_string ("Unable to append argument"), object);
678 return;
681 case DBUS_TYPE_DOUBLE:
683 double val = extract_float (object);
684 XD_DEBUG_MESSAGE ("%c %f", dtype, val);
685 if (!dbus_message_iter_append_basic (iter, dtype, &val))
686 XD_SIGNAL2 (build_string ("Unable to append argument"), object);
687 return;
690 case DBUS_TYPE_STRING:
691 case DBUS_TYPE_OBJECT_PATH:
692 case DBUS_TYPE_SIGNATURE:
693 CHECK_STRING (object);
695 /* We need to send a valid UTF-8 string. We could encode `object'
696 but by not encoding it, we guarantee it's valid utf-8, even if
697 it contains eight-bit-bytes. Of course, you can still send
698 manually-crafted junk by passing a unibyte string. */
699 char *val = SSDATA (object);
700 XD_DEBUG_MESSAGE ("%c %s", dtype, val);
701 if (!dbus_message_iter_append_basic (iter, dtype, &val))
702 XD_SIGNAL2 (build_string ("Unable to append argument"), object);
703 return;
707 else /* Compound types. */
710 /* All compound types except array have a type symbol. For
711 array, it is optional. Skip it. */
712 if (!XD_BASIC_DBUS_TYPE (XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object))))
713 object = XD_NEXT_VALUE (object);
715 /* Open new subiteration. */
716 switch (dtype)
718 case DBUS_TYPE_ARRAY:
719 /* An array has only elements of the same type. So it is
720 sufficient to check the first element's signature
721 only. */
723 if (NILP (object))
724 /* If the array is empty, DBUS_TYPE_STRING is the default
725 element type. */
726 strcpy (signature, DBUS_TYPE_STRING_AS_STRING);
728 else
729 /* If the element type is DBUS_TYPE_SIGNATURE, and this is
730 the only element, the value of this element is used as
731 the array's element signature. */
732 if ((XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object))
733 == DBUS_TYPE_SIGNATURE)
734 && STRINGP (CAR_SAFE (XD_NEXT_VALUE (object)))
735 && NILP (CDR_SAFE (XD_NEXT_VALUE (object))))
737 lispstpcpy (signature, CAR_SAFE (XD_NEXT_VALUE (object)));
738 object = CDR_SAFE (XD_NEXT_VALUE (object));
741 else
742 xd_signature (signature,
743 XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object)),
744 dtype, CAR_SAFE (XD_NEXT_VALUE (object)));
746 XD_DEBUG_MESSAGE ("%c %s %s", dtype, signature,
747 XD_OBJECT_TO_STRING (object));
748 if (!dbus_message_iter_open_container (iter, dtype,
749 signature, &subiter))
750 XD_SIGNAL3 (build_string ("Cannot open container"),
751 make_number (dtype), build_string (signature));
752 break;
754 case DBUS_TYPE_VARIANT:
755 /* A variant has just one element. */
756 xd_signature (signature, XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object)),
757 dtype, CAR_SAFE (XD_NEXT_VALUE (object)));
759 XD_DEBUG_MESSAGE ("%c %s %s", dtype, signature,
760 XD_OBJECT_TO_STRING (object));
761 if (!dbus_message_iter_open_container (iter, dtype,
762 signature, &subiter))
763 XD_SIGNAL3 (build_string ("Cannot open container"),
764 make_number (dtype), build_string (signature));
765 break;
767 case DBUS_TYPE_STRUCT:
768 case DBUS_TYPE_DICT_ENTRY:
769 /* These containers do not require a signature. */
770 XD_DEBUG_MESSAGE ("%c %s", dtype, XD_OBJECT_TO_STRING (object));
771 if (!dbus_message_iter_open_container (iter, dtype, NULL, &subiter))
772 XD_SIGNAL2 (build_string ("Cannot open container"),
773 make_number (dtype));
774 break;
777 /* Loop over list elements. */
778 while (!NILP (object))
780 dtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object));
781 object = XD_NEXT_VALUE (object);
783 xd_append_arg (dtype, CAR_SAFE (object), &subiter);
785 object = CDR_SAFE (object);
788 /* Close the subiteration. */
789 if (!dbus_message_iter_close_container (iter, &subiter))
790 XD_SIGNAL2 (build_string ("Cannot close container"),
791 make_number (dtype));
795 /* Retrieve C value from a DBusMessageIter structure ITER, and return
796 a converted Lisp object. The type DTYPE of the argument of the
797 D-Bus message must be a valid DBusType. Compound D-Bus types
798 result always in a Lisp list. */
799 static Lisp_Object
800 xd_retrieve_arg (int dtype, DBusMessageIter *iter)
803 switch (dtype)
805 case DBUS_TYPE_BYTE:
807 unsigned int val;
808 dbus_message_iter_get_basic (iter, &val);
809 val = val & 0xFF;
810 XD_DEBUG_MESSAGE ("%c %u", dtype, val);
811 return make_number (val);
814 case DBUS_TYPE_BOOLEAN:
816 dbus_bool_t val;
817 dbus_message_iter_get_basic (iter, &val);
818 XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true");
819 return (val == FALSE) ? Qnil : Qt;
822 case DBUS_TYPE_INT16:
824 dbus_int16_t val;
825 int pval;
826 dbus_message_iter_get_basic (iter, &val);
827 pval = val;
828 XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
829 return make_number (val);
832 case DBUS_TYPE_UINT16:
834 dbus_uint16_t val;
835 int pval;
836 dbus_message_iter_get_basic (iter, &val);
837 pval = val;
838 XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
839 return make_number (val);
842 case DBUS_TYPE_INT32:
844 dbus_int32_t val;
845 int pval;
846 dbus_message_iter_get_basic (iter, &val);
847 pval = val;
848 XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
849 return make_fixnum_or_float (val);
852 case DBUS_TYPE_UINT32:
853 #ifdef DBUS_TYPE_UNIX_FD
854 case DBUS_TYPE_UNIX_FD:
855 #endif
857 dbus_uint32_t val;
858 unsigned int pval;
859 dbus_message_iter_get_basic (iter, &val);
860 pval = val;
861 XD_DEBUG_MESSAGE ("%c %u", dtype, pval);
862 return make_fixnum_or_float (val);
865 case DBUS_TYPE_INT64:
867 dbus_int64_t val;
868 printmax_t pval;
869 dbus_message_iter_get_basic (iter, &val);
870 pval = val;
871 XD_DEBUG_MESSAGE ("%c %"pMd, dtype, pval);
872 return make_fixnum_or_float (val);
875 case DBUS_TYPE_UINT64:
877 dbus_uint64_t val;
878 uprintmax_t pval;
879 dbus_message_iter_get_basic (iter, &val);
880 pval = val;
881 XD_DEBUG_MESSAGE ("%c %"pMu, dtype, pval);
882 return make_fixnum_or_float (val);
885 case DBUS_TYPE_DOUBLE:
887 double val;
888 dbus_message_iter_get_basic (iter, &val);
889 XD_DEBUG_MESSAGE ("%c %f", dtype, val);
890 return make_float (val);
893 case DBUS_TYPE_STRING:
894 case DBUS_TYPE_OBJECT_PATH:
895 case DBUS_TYPE_SIGNATURE:
897 char *val;
898 dbus_message_iter_get_basic (iter, &val);
899 XD_DEBUG_MESSAGE ("%c %s", dtype, val);
900 return build_string (val);
903 case DBUS_TYPE_ARRAY:
904 case DBUS_TYPE_VARIANT:
905 case DBUS_TYPE_STRUCT:
906 case DBUS_TYPE_DICT_ENTRY:
908 Lisp_Object result;
909 struct gcpro gcpro1;
910 DBusMessageIter subiter;
911 int subtype;
912 result = Qnil;
913 GCPRO1 (result);
914 dbus_message_iter_recurse (iter, &subiter);
915 while ((subtype = dbus_message_iter_get_arg_type (&subiter))
916 != DBUS_TYPE_INVALID)
918 result = Fcons (xd_retrieve_arg (subtype, &subiter), result);
919 dbus_message_iter_next (&subiter);
921 XD_DEBUG_MESSAGE ("%c %s", dtype, XD_OBJECT_TO_STRING (result));
922 RETURN_UNGCPRO (Fnreverse (result));
925 default:
926 XD_DEBUG_MESSAGE ("DBusType '%c' not supported", dtype);
927 return Qnil;
931 /* Return the number of references of the shared CONNECTION. */
932 static ptrdiff_t
933 xd_get_connection_references (DBusConnection *connection)
935 ptrdiff_t *refcount;
937 /* We cannot access the DBusConnection structure, it is not public.
938 But we know, that the reference counter is the first field in
939 that structure. */
940 refcount = (void *) &connection;
941 refcount = (void *) *refcount;
942 return *refcount;
945 /* Convert a Lisp D-Bus object to a pointer. */
946 static DBusConnection*
947 xd_lisp_dbus_to_dbus (Lisp_Object bus)
949 return (DBusConnection *) (intptr_t) XFASTINT (bus);
952 /* Return D-Bus connection address. BUS is either a Lisp symbol,
953 :system or :session, or a string denoting the bus address. */
954 static DBusConnection *
955 xd_get_connection_address (Lisp_Object bus)
957 DBusConnection *connection;
958 Lisp_Object val;
960 val = CDR_SAFE (Fassoc (bus, xd_registered_buses));
961 if (NILP (val))
962 XD_SIGNAL2 (build_string ("No connection to bus"), bus);
963 else
964 connection = xd_lisp_dbus_to_dbus (val);
966 if (!dbus_connection_get_is_connected (connection))
967 XD_SIGNAL2 (build_string ("No connection to bus"), bus);
969 return connection;
972 /* Return the file descriptor for WATCH, -1 if not found. */
973 static int
974 xd_find_watch_fd (DBusWatch *watch)
976 #if HAVE_DBUS_WATCH_GET_UNIX_FD
977 /* TODO: Reverse these on w32, which prefers the opposite. */
978 int fd = dbus_watch_get_unix_fd (watch);
979 if (fd == -1)
980 fd = dbus_watch_get_socket (watch);
981 #else
982 int fd = dbus_watch_get_fd (watch);
983 #endif
984 return fd;
987 /* Prototype. */
988 static void xd_read_queued_messages (int fd, void *data);
990 /* Start monitoring WATCH for possible I/O. */
991 static dbus_bool_t
992 xd_add_watch (DBusWatch *watch, void *data)
994 unsigned int flags = dbus_watch_get_flags (watch);
995 int fd = xd_find_watch_fd (watch);
997 XD_DEBUG_MESSAGE ("fd %d, write %u, enabled %u",
998 fd, flags & DBUS_WATCH_WRITABLE,
999 dbus_watch_get_enabled (watch));
1001 if (fd == -1)
1002 return FALSE;
1004 if (dbus_watch_get_enabled (watch))
1006 if (flags & DBUS_WATCH_WRITABLE)
1007 add_write_fd (fd, xd_read_queued_messages, data);
1008 if (flags & DBUS_WATCH_READABLE)
1009 add_read_fd (fd, xd_read_queued_messages, data);
1011 return TRUE;
1014 /* Stop monitoring WATCH for possible I/O.
1015 DATA is the used bus, either a string or QCdbus_system_bus or
1016 QCdbus_session_bus. */
1017 static void
1018 xd_remove_watch (DBusWatch *watch, void *data)
1020 unsigned int flags = dbus_watch_get_flags (watch);
1021 int fd = xd_find_watch_fd (watch);
1023 XD_DEBUG_MESSAGE ("fd %d", fd);
1025 if (fd == -1)
1026 return;
1028 /* Unset session environment. */
1029 #if 0
1030 /* This is buggy, since unsetenv is not thread-safe. */
1031 if (XSYMBOL (QCdbus_session_bus) == data)
1033 XD_DEBUG_MESSAGE ("unsetenv DBUS_SESSION_BUS_ADDRESS");
1034 unsetenv ("DBUS_SESSION_BUS_ADDRESS");
1036 #endif
1038 if (flags & DBUS_WATCH_WRITABLE)
1039 delete_write_fd (fd);
1040 if (flags & DBUS_WATCH_READABLE)
1041 delete_read_fd (fd);
1044 /* Toggle monitoring WATCH for possible I/O. */
1045 static void
1046 xd_toggle_watch (DBusWatch *watch, void *data)
1048 if (dbus_watch_get_enabled (watch))
1049 xd_add_watch (watch, data);
1050 else
1051 xd_remove_watch (watch, data);
1054 /* Close connection to D-Bus BUS. */
1055 static void
1056 xd_close_bus (Lisp_Object bus)
1058 DBusConnection *connection;
1059 Lisp_Object val;
1060 Lisp_Object busobj;
1062 /* Check whether we are connected. */
1063 val = Fassoc (bus, xd_registered_buses);
1064 if (NILP (val))
1065 return;
1067 busobj = CDR_SAFE (val);
1068 if (NILP (busobj)) {
1069 xd_registered_buses = Fdelete (val, xd_registered_buses);
1070 return;
1073 /* Retrieve bus address. */
1074 connection = xd_lisp_dbus_to_dbus (busobj);
1076 if (xd_get_connection_references (connection) == 1)
1078 /* Close connection, if there isn't another shared application. */
1079 XD_DEBUG_MESSAGE ("Close connection to bus %s",
1080 XD_OBJECT_TO_STRING (bus));
1081 dbus_connection_close (connection);
1083 xd_registered_buses = Fdelete (val, xd_registered_buses);
1086 else
1087 /* Decrement reference count. */
1088 dbus_connection_unref (connection);
1090 /* Return. */
1091 return;
1094 DEFUN ("dbus--init-bus", Fdbus__init_bus, Sdbus__init_bus, 1, 2, 0,
1095 doc: /* Establish the connection to D-Bus BUS.
1097 This function is dbus internal. You almost certainly want to use
1098 `dbus-init-bus'.
1100 BUS can be either the symbol `:system' or the symbol `:session', or it
1101 can be a string denoting the address of the corresponding bus. For
1102 the system and session buses, this function is called when loading
1103 `dbus.el', there is no need to call it again.
1105 The function returns a number, which counts the connections this Emacs
1106 session has established to the BUS under the same unique name (see
1107 `dbus-get-unique-name'). It depends on the libraries Emacs is linked
1108 with, and on the environment Emacs is running. For example, if Emacs
1109 is linked with the gtk toolkit, and it runs in a GTK-aware environment
1110 like Gnome, another connection might already be established.
1112 When PRIVATE is non-nil, a new connection is established instead of
1113 reusing an existing one. It results in a new unique name at the bus.
1114 This can be used, if it is necessary to distinguish from another
1115 connection used in the same Emacs process, like the one established by
1116 GTK+. It should be used with care for at least the `:system' and
1117 `:session' buses, because other Emacs Lisp packages might already use
1118 this connection to those buses. */)
1119 (Lisp_Object bus, Lisp_Object private)
1121 DBusConnection *connection;
1122 DBusError derror;
1123 Lisp_Object val;
1124 ptrdiff_t refcount;
1126 /* Check parameter. */
1127 XD_DBUS_VALIDATE_BUS_ADDRESS (bus);
1129 /* Close bus if it is already open. */
1130 xd_close_bus (bus);
1132 /* Check, whether we are still connected. */
1133 val = Fassoc (bus, xd_registered_buses);
1134 if (!NILP (val))
1136 connection = xd_get_connection_address (bus);
1137 dbus_connection_ref (connection);
1140 else
1142 /* Initialize. */
1143 dbus_error_init (&derror);
1145 /* Open the connection. */
1146 if (STRINGP (bus))
1147 if (NILP (private))
1148 connection = dbus_connection_open (SSDATA (bus), &derror);
1149 else
1150 connection = dbus_connection_open_private (SSDATA (bus), &derror);
1152 else
1153 if (NILP (private))
1154 connection = dbus_bus_get (EQ (bus, QCdbus_system_bus)
1155 ? DBUS_BUS_SYSTEM : DBUS_BUS_SESSION,
1156 &derror);
1157 else
1158 connection = dbus_bus_get_private (EQ (bus, QCdbus_system_bus)
1159 ? DBUS_BUS_SYSTEM : DBUS_BUS_SESSION,
1160 &derror);
1162 if (dbus_error_is_set (&derror))
1163 XD_ERROR (derror);
1165 if (connection == NULL)
1166 XD_SIGNAL2 (build_string ("No connection to bus"), bus);
1168 /* If it is not the system or session bus, we must register
1169 ourselves. Otherwise, we have called dbus_bus_get, which has
1170 configured us to exit if the connection closes - we undo this
1171 setting. */
1172 if (STRINGP (bus))
1173 dbus_bus_register (connection, &derror);
1174 else
1175 dbus_connection_set_exit_on_disconnect (connection, FALSE);
1177 if (dbus_error_is_set (&derror))
1178 XD_ERROR (derror);
1180 /* Add the watch functions. We pass also the bus as data, in
1181 order to distinguish between the buses in xd_remove_watch. */
1182 if (!dbus_connection_set_watch_functions (connection,
1183 xd_add_watch,
1184 xd_remove_watch,
1185 xd_toggle_watch,
1186 SYMBOLP (bus)
1187 ? (void *) XSYMBOL (bus)
1188 : (void *) XSTRING (bus),
1189 NULL))
1190 XD_SIGNAL1 (build_string ("Cannot add watch functions"));
1192 /* Add bus to list of registered buses. */
1193 XSETFASTINT (val, (intptr_t) connection);
1194 xd_registered_buses = Fcons (Fcons (bus, val), xd_registered_buses);
1196 /* Cleanup. */
1197 dbus_error_free (&derror);
1200 /* Return reference counter. */
1201 refcount = xd_get_connection_references (connection);
1202 XD_DEBUG_MESSAGE ("Bus %s, Reference counter %"pD"d",
1203 XD_OBJECT_TO_STRING (bus), refcount);
1204 return make_number (refcount);
1207 DEFUN ("dbus-get-unique-name", Fdbus_get_unique_name, Sdbus_get_unique_name,
1208 1, 1, 0,
1209 doc: /* Return the unique name of Emacs registered at D-Bus BUS. */)
1210 (Lisp_Object bus)
1212 DBusConnection *connection;
1213 const char *name;
1215 /* Check parameter. */
1216 XD_DBUS_VALIDATE_BUS_ADDRESS (bus);
1218 /* Retrieve bus address. */
1219 connection = xd_get_connection_address (bus);
1221 /* Request the name. */
1222 name = dbus_bus_get_unique_name (connection);
1223 if (name == NULL)
1224 XD_SIGNAL1 (build_string ("No unique name available"));
1226 /* Return. */
1227 return build_string (name);
1230 DEFUN ("dbus-message-internal", Fdbus_message_internal, Sdbus_message_internal,
1231 4, MANY, 0,
1232 doc: /* Send a D-Bus message.
1233 This is an internal function, it shall not be used outside dbus.el.
1235 The following usages are expected:
1237 `dbus-call-method', `dbus-call-method-asynchronously':
1238 \(dbus-message-internal
1239 dbus-message-type-method-call BUS SERVICE PATH INTERFACE METHOD HANDLER
1240 &optional :timeout TIMEOUT &rest ARGS)
1242 `dbus-send-signal':
1243 \(dbus-message-internal
1244 dbus-message-type-signal BUS SERVICE PATH INTERFACE SIGNAL &rest ARGS)
1246 `dbus-method-return-internal':
1247 \(dbus-message-internal
1248 dbus-message-type-method-return BUS SERVICE SERIAL &rest ARGS)
1250 `dbus-method-error-internal':
1251 \(dbus-message-internal
1252 dbus-message-type-error BUS SERVICE SERIAL &rest ARGS)
1254 usage: (dbus-message-internal &rest REST) */)
1255 (ptrdiff_t nargs, Lisp_Object *args)
1257 Lisp_Object message_type, bus, service, handler;
1258 Lisp_Object path = Qnil;
1259 Lisp_Object interface = Qnil;
1260 Lisp_Object member = Qnil;
1261 Lisp_Object result;
1262 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5, gcpro6;
1263 DBusConnection *connection;
1264 DBusMessage *dmessage;
1265 DBusMessageIter iter;
1266 int dtype;
1267 int mtype;
1268 dbus_uint32_t serial = 0;
1269 unsigned int ui_serial;
1270 int timeout = -1;
1271 ptrdiff_t count;
1272 char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1274 /* Initialize parameters. */
1275 message_type = args[0];
1276 bus = args[1];
1277 service = args[2];
1278 handler = Qnil;
1280 CHECK_NATNUM (message_type);
1281 if (! (DBUS_MESSAGE_TYPE_INVALID < XFASTINT (message_type)
1282 && XFASTINT (message_type) < DBUS_NUM_MESSAGE_TYPES))
1283 XD_SIGNAL2 (build_string ("Invalid message type"), message_type);
1284 mtype = XFASTINT (message_type);
1286 if ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1287 || (mtype == DBUS_MESSAGE_TYPE_SIGNAL))
1289 path = args[3];
1290 interface = args[4];
1291 member = args[5];
1292 if (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1293 handler = args[6];
1294 count = (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL) ? 7 : 6;
1296 else /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR */
1298 serial = xd_extract_unsigned (args[3], TYPE_MAXIMUM (dbus_uint32_t));
1299 count = 4;
1302 /* Check parameters. */
1303 XD_DBUS_VALIDATE_BUS_ADDRESS (bus);
1304 XD_DBUS_VALIDATE_BUS_NAME (service);
1305 if (nargs < count)
1306 xsignal2 (Qwrong_number_of_arguments,
1307 Qdbus_message_internal,
1308 make_number (nargs));
1310 if ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1311 || (mtype == DBUS_MESSAGE_TYPE_SIGNAL))
1313 XD_DBUS_VALIDATE_PATH (path);
1314 XD_DBUS_VALIDATE_INTERFACE (interface);
1315 XD_DBUS_VALIDATE_MEMBER (member);
1316 if (!NILP (handler) && (!FUNCTIONP (handler)))
1317 wrong_type_argument (Qinvalid_function, handler);
1320 /* Protect Lisp variables. */
1321 GCPRO6 (bus, service, path, interface, member, handler);
1323 /* Trace parameters. */
1324 switch (mtype)
1326 case DBUS_MESSAGE_TYPE_METHOD_CALL:
1327 XD_DEBUG_MESSAGE ("%s %s %s %s %s %s %s",
1328 XD_MESSAGE_TYPE_TO_STRING (mtype),
1329 XD_OBJECT_TO_STRING (bus),
1330 XD_OBJECT_TO_STRING (service),
1331 XD_OBJECT_TO_STRING (path),
1332 XD_OBJECT_TO_STRING (interface),
1333 XD_OBJECT_TO_STRING (member),
1334 XD_OBJECT_TO_STRING (handler));
1335 break;
1336 case DBUS_MESSAGE_TYPE_SIGNAL:
1337 XD_DEBUG_MESSAGE ("%s %s %s %s %s %s",
1338 XD_MESSAGE_TYPE_TO_STRING (mtype),
1339 XD_OBJECT_TO_STRING (bus),
1340 XD_OBJECT_TO_STRING (service),
1341 XD_OBJECT_TO_STRING (path),
1342 XD_OBJECT_TO_STRING (interface),
1343 XD_OBJECT_TO_STRING (member));
1344 break;
1345 default: /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR */
1346 ui_serial = serial;
1347 XD_DEBUG_MESSAGE ("%s %s %s %u",
1348 XD_MESSAGE_TYPE_TO_STRING (mtype),
1349 XD_OBJECT_TO_STRING (bus),
1350 XD_OBJECT_TO_STRING (service),
1351 ui_serial);
1354 /* Retrieve bus address. */
1355 connection = xd_get_connection_address (bus);
1357 /* Create the D-Bus message. */
1358 dmessage = dbus_message_new (mtype);
1359 if (dmessage == NULL)
1361 UNGCPRO;
1362 XD_SIGNAL1 (build_string ("Unable to create a new message"));
1365 if (STRINGP (service))
1367 if (mtype != DBUS_MESSAGE_TYPE_SIGNAL)
1368 /* Set destination. */
1370 if (!dbus_message_set_destination (dmessage, SSDATA (service)))
1372 UNGCPRO;
1373 XD_SIGNAL2 (build_string ("Unable to set the destination"),
1374 service);
1378 else
1379 /* Set destination for unicast signals. */
1381 Lisp_Object uname;
1383 /* If it is the same unique name as we are registered at the
1384 bus or an unknown name, we regard it as broadcast message
1385 due to backward compatibility. */
1386 if (dbus_bus_name_has_owner (connection, SSDATA (service), NULL))
1387 uname = call2 (intern ("dbus-get-name-owner"), bus, service);
1388 else
1389 uname = Qnil;
1391 if (STRINGP (uname)
1392 && (strcmp (dbus_bus_get_unique_name (connection), SSDATA (uname))
1393 != 0)
1394 && (!dbus_message_set_destination (dmessage, SSDATA (service))))
1396 UNGCPRO;
1397 XD_SIGNAL2 (build_string ("Unable to set signal destination"),
1398 service);
1403 /* Set message parameters. */
1404 if ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1405 || (mtype == DBUS_MESSAGE_TYPE_SIGNAL))
1407 if ((!dbus_message_set_path (dmessage, SSDATA (path)))
1408 || (!dbus_message_set_interface (dmessage, SSDATA (interface)))
1409 || (!dbus_message_set_member (dmessage, SSDATA (member))))
1411 UNGCPRO;
1412 XD_SIGNAL1 (build_string ("Unable to set the message parameter"));
1416 else /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR */
1418 if (!dbus_message_set_reply_serial (dmessage, serial))
1420 UNGCPRO;
1421 XD_SIGNAL1 (build_string ("Unable to create a return message"));
1424 if ((mtype == DBUS_MESSAGE_TYPE_ERROR)
1425 && (!dbus_message_set_error_name (dmessage, DBUS_ERROR_FAILED)))
1427 UNGCPRO;
1428 XD_SIGNAL1 (build_string ("Unable to create a error message"));
1432 /* Check for timeout parameter. */
1433 if ((count+2 <= nargs) && (EQ ((args[count]), QCdbus_timeout)))
1435 CHECK_NATNUM (args[count+1]);
1436 timeout = min (XFASTINT (args[count+1]), INT_MAX);
1437 count = count+2;
1440 /* Initialize parameter list of message. */
1441 dbus_message_iter_init_append (dmessage, &iter);
1443 /* Append parameters to the message. */
1444 for (; count < nargs; ++count)
1446 dtype = XD_OBJECT_TO_DBUS_TYPE (args[count]);
1447 if (XD_DBUS_TYPE_P (args[count]))
1449 XD_DEBUG_VALID_LISP_OBJECT_P (args[count]);
1450 XD_DEBUG_VALID_LISP_OBJECT_P (args[count+1]);
1451 XD_DEBUG_MESSAGE ("Parameter%"pD"d %s %s", count - 4,
1452 XD_OBJECT_TO_STRING (args[count]),
1453 XD_OBJECT_TO_STRING (args[count+1]));
1454 ++count;
1456 else
1458 XD_DEBUG_VALID_LISP_OBJECT_P (args[count]);
1459 XD_DEBUG_MESSAGE ("Parameter%"pD"d %s", count - 4,
1460 XD_OBJECT_TO_STRING (args[count]));
1463 /* Check for valid signature. We use DBUS_TYPE_INVALID as
1464 indication that there is no parent type. */
1465 xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[count]);
1467 xd_append_arg (dtype, args[count], &iter);
1470 if (!NILP (handler))
1472 /* Send the message. The message is just added to the outgoing
1473 message queue. */
1474 if (!dbus_connection_send_with_reply (connection, dmessage,
1475 NULL, timeout))
1477 UNGCPRO;
1478 XD_SIGNAL1 (build_string ("Cannot send message"));
1481 /* The result is the key in Vdbus_registered_objects_table. */
1482 serial = dbus_message_get_serial (dmessage);
1483 result = list3 (QCdbus_registered_serial,
1484 bus, make_fixnum_or_float (serial));
1486 /* Create a hash table entry. */
1487 Fputhash (result, handler, Vdbus_registered_objects_table);
1489 else
1491 /* Send the message. The message is just added to the outgoing
1492 message queue. */
1493 if (!dbus_connection_send (connection, dmessage, NULL))
1495 UNGCPRO;
1496 XD_SIGNAL1 (build_string ("Cannot send message"));
1499 result = Qnil;
1502 XD_DEBUG_MESSAGE ("Message sent: %s", XD_OBJECT_TO_STRING (result));
1504 /* Cleanup. */
1505 dbus_message_unref (dmessage);
1507 /* Return the result. */
1508 RETURN_UNGCPRO (result);
1511 /* Read one queued incoming message of the D-Bus BUS.
1512 BUS is either a Lisp symbol, :system or :session, or a string denoting
1513 the bus address. */
1514 static void
1515 xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
1517 Lisp_Object args, key, value;
1518 struct gcpro gcpro1;
1519 struct input_event event;
1520 DBusMessage *dmessage;
1521 DBusMessageIter iter;
1522 int dtype;
1523 int mtype;
1524 dbus_uint32_t serial;
1525 unsigned int ui_serial;
1526 const char *uname, *path, *interface, *member;
1528 dmessage = dbus_connection_pop_message (connection);
1530 /* Return if there is no queued message. */
1531 if (dmessage == NULL)
1532 return;
1534 /* Collect the parameters. */
1535 args = Qnil;
1536 GCPRO1 (args);
1538 /* Loop over the resulting parameters. Construct a list. */
1539 if (dbus_message_iter_init (dmessage, &iter))
1541 while ((dtype = dbus_message_iter_get_arg_type (&iter))
1542 != DBUS_TYPE_INVALID)
1544 args = Fcons (xd_retrieve_arg (dtype, &iter), args);
1545 dbus_message_iter_next (&iter);
1547 /* The arguments are stored in reverse order. Reorder them. */
1548 args = Fnreverse (args);
1551 /* Read message type, message serial, unique name, object path,
1552 interface and member from the message. */
1553 mtype = dbus_message_get_type (dmessage);
1554 ui_serial = serial =
1555 ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1556 || (mtype == DBUS_MESSAGE_TYPE_ERROR))
1557 ? dbus_message_get_reply_serial (dmessage)
1558 : dbus_message_get_serial (dmessage);
1559 uname = dbus_message_get_sender (dmessage);
1560 path = dbus_message_get_path (dmessage);
1561 interface = dbus_message_get_interface (dmessage);
1562 member = dbus_message_get_member (dmessage);
1564 XD_DEBUG_MESSAGE ("Event received: %s %u %s %s %s %s %s",
1565 XD_MESSAGE_TYPE_TO_STRING (mtype),
1566 ui_serial, uname, path, interface, member,
1567 XD_OBJECT_TO_STRING (args));
1569 if (mtype == DBUS_MESSAGE_TYPE_INVALID)
1570 goto cleanup;
1572 else if ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1573 || (mtype == DBUS_MESSAGE_TYPE_ERROR))
1575 /* Search for a registered function of the message. */
1576 key = list3 (QCdbus_registered_serial, bus,
1577 make_fixnum_or_float (serial));
1578 value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1580 /* There shall be exactly one entry. Construct an event. */
1581 if (NILP (value))
1582 goto cleanup;
1584 /* Remove the entry. */
1585 Fremhash (key, Vdbus_registered_objects_table);
1587 /* Construct an event. */
1588 EVENT_INIT (event);
1589 event.kind = DBUS_EVENT;
1590 event.frame_or_window = Qnil;
1591 event.arg = Fcons (value, args);
1594 else /* DBUS_MESSAGE_TYPE_METHOD_CALL, DBUS_MESSAGE_TYPE_SIGNAL. */
1596 /* Vdbus_registered_objects_table requires non-nil interface and
1597 member. */
1598 if ((interface == NULL) || (member == NULL))
1599 goto cleanup;
1601 /* Search for a registered function of the message. */
1602 key = list4 ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1603 ? QCdbus_registered_method
1604 : QCdbus_registered_signal,
1605 bus, build_string (interface), build_string (member));
1606 value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1608 /* Loop over the registered functions. Construct an event. */
1609 while (!NILP (value))
1611 key = CAR_SAFE (value);
1612 /* key has the structure (UNAME SERVICE PATH HANDLER). */
1613 if (((uname == NULL)
1614 || (NILP (CAR_SAFE (key)))
1615 || (strcmp (uname, SSDATA (CAR_SAFE (key))) == 0))
1616 && ((path == NULL)
1617 || (NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1618 || (strcmp (path,
1619 SSDATA (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1620 == 0))
1621 && (!NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))))))
1623 EVENT_INIT (event);
1624 event.kind = DBUS_EVENT;
1625 event.frame_or_window = Qnil;
1626 event.arg
1627 = Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))), args);
1628 break;
1630 value = CDR_SAFE (value);
1633 if (NILP (value))
1634 goto cleanup;
1637 /* Add type, serial, uname, path, interface and member to the event. */
1638 event.arg = Fcons ((member == NULL ? Qnil : build_string (member)),
1639 event.arg);
1640 event.arg = Fcons ((interface == NULL ? Qnil : build_string (interface)),
1641 event.arg);
1642 event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
1643 event.arg);
1644 event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
1645 event.arg);
1646 event.arg = Fcons (make_fixnum_or_float (serial), event.arg);
1647 event.arg = Fcons (make_number (mtype), event.arg);
1649 /* Add the bus symbol to the event. */
1650 event.arg = Fcons (bus, event.arg);
1652 /* Store it into the input event queue. */
1653 kbd_buffer_store_event (&event);
1655 XD_DEBUG_MESSAGE ("Event stored: %s", XD_OBJECT_TO_STRING (event.arg));
1657 /* Cleanup. */
1658 cleanup:
1659 dbus_message_unref (dmessage);
1661 UNGCPRO;
1664 /* Read queued incoming messages of the D-Bus BUS.
1665 BUS is either a Lisp symbol, :system or :session, or a string denoting
1666 the bus address. */
1667 static Lisp_Object
1668 xd_read_message (Lisp_Object bus)
1670 /* Retrieve bus address. */
1671 DBusConnection *connection = xd_get_connection_address (bus);
1673 /* Non blocking read of the next available message. */
1674 dbus_connection_read_write (connection, 0);
1676 while (dbus_connection_get_dispatch_status (connection)
1677 != DBUS_DISPATCH_COMPLETE)
1678 xd_read_message_1 (connection, bus);
1679 return Qnil;
1682 /* Callback called when something is ready to read or write. */
1683 static void
1684 xd_read_queued_messages (int fd, void *data)
1686 Lisp_Object busp = xd_registered_buses;
1687 Lisp_Object bus = Qnil;
1688 Lisp_Object key;
1690 /* Find bus related to fd. */
1691 if (data != NULL)
1692 while (!NILP (busp))
1694 key = CAR_SAFE (CAR_SAFE (busp));
1695 if ((SYMBOLP (key) && XSYMBOL (key) == data)
1696 || (STRINGP (key) && XSTRING (key) == data))
1697 bus = key;
1698 busp = CDR_SAFE (busp);
1701 if (NILP (bus))
1702 return;
1704 /* We ignore all Lisp errors during the call. */
1705 xd_in_read_queued_messages = 1;
1706 internal_catch (Qdbus_error, xd_read_message, bus);
1707 xd_in_read_queued_messages = 0;
1711 void
1712 init_dbusbind (void)
1714 /* We do not want to abort. */
1715 xputenv ("DBUS_FATAL_WARNINGS=0");
1718 void
1719 syms_of_dbusbind (void)
1721 defsubr (&Sdbus__init_bus);
1722 defsubr (&Sdbus_get_unique_name);
1724 DEFSYM (Qdbus_message_internal, "dbus-message-internal");
1725 defsubr (&Sdbus_message_internal);
1727 /* D-Bus error symbol. */
1728 DEFSYM (Qdbus_error, "dbus-error");
1729 Fput (Qdbus_error, Qerror_conditions,
1730 list2 (Qdbus_error, Qerror));
1731 Fput (Qdbus_error, Qerror_message,
1732 build_pure_c_string ("D-Bus error"));
1734 /* Lisp symbols of the system and session buses. */
1735 DEFSYM (QCdbus_system_bus, ":system");
1736 DEFSYM (QCdbus_session_bus, ":session");
1738 /* Lisp symbol for method call timeout. */
1739 DEFSYM (QCdbus_timeout, ":timeout");
1741 /* Lisp symbols of D-Bus types. */
1742 DEFSYM (QCdbus_type_byte, ":byte");
1743 DEFSYM (QCdbus_type_boolean, ":boolean");
1744 DEFSYM (QCdbus_type_int16, ":int16");
1745 DEFSYM (QCdbus_type_uint16, ":uint16");
1746 DEFSYM (QCdbus_type_int32, ":int32");
1747 DEFSYM (QCdbus_type_uint32, ":uint32");
1748 DEFSYM (QCdbus_type_int64, ":int64");
1749 DEFSYM (QCdbus_type_uint64, ":uint64");
1750 DEFSYM (QCdbus_type_double, ":double");
1751 DEFSYM (QCdbus_type_string, ":string");
1752 DEFSYM (QCdbus_type_object_path, ":object-path");
1753 DEFSYM (QCdbus_type_signature, ":signature");
1754 #ifdef DBUS_TYPE_UNIX_FD
1755 DEFSYM (QCdbus_type_unix_fd, ":unix-fd");
1756 #endif
1757 DEFSYM (QCdbus_type_array, ":array");
1758 DEFSYM (QCdbus_type_variant, ":variant");
1759 DEFSYM (QCdbus_type_struct, ":struct");
1760 DEFSYM (QCdbus_type_dict_entry, ":dict-entry");
1762 /* Lisp symbols of objects in `dbus-registered-objects-table'. */
1763 DEFSYM (QCdbus_registered_serial, ":serial");
1764 DEFSYM (QCdbus_registered_method, ":method");
1765 DEFSYM (QCdbus_registered_signal, ":signal");
1767 DEFVAR_LISP ("dbus-compiled-version",
1768 Vdbus_compiled_version,
1769 doc: /* The version of D-Bus Emacs is compiled against. */);
1770 #ifdef DBUS_VERSION_STRING
1771 Vdbus_compiled_version = build_pure_c_string (DBUS_VERSION_STRING);
1772 #else
1773 Vdbus_compiled_version = Qnil;
1774 #endif
1776 DEFVAR_LISP ("dbus-runtime-version",
1777 Vdbus_runtime_version,
1778 doc: /* The version of D-Bus Emacs runs with. */);
1780 #ifdef DBUS_VERSION
1781 int major, minor, micro;
1782 char s[sizeof ".." + 3 * INT_STRLEN_BOUND (int)];
1783 dbus_get_version (&major, &minor, &micro);
1784 Vdbus_runtime_version
1785 = make_formatted_string (s, "%d.%d.%d", major, minor, micro);
1786 #else
1787 Vdbus_runtime_version = Qnil;
1788 #endif
1791 DEFVAR_LISP ("dbus-message-type-invalid",
1792 Vdbus_message_type_invalid,
1793 doc: /* This value is never a valid message type. */);
1794 Vdbus_message_type_invalid = make_number (DBUS_MESSAGE_TYPE_INVALID);
1796 DEFVAR_LISP ("dbus-message-type-method-call",
1797 Vdbus_message_type_method_call,
1798 doc: /* Message type of a method call message. */);
1799 Vdbus_message_type_method_call = make_number (DBUS_MESSAGE_TYPE_METHOD_CALL);
1801 DEFVAR_LISP ("dbus-message-type-method-return",
1802 Vdbus_message_type_method_return,
1803 doc: /* Message type of a method return message. */);
1804 Vdbus_message_type_method_return
1805 = make_number (DBUS_MESSAGE_TYPE_METHOD_RETURN);
1807 DEFVAR_LISP ("dbus-message-type-error",
1808 Vdbus_message_type_error,
1809 doc: /* Message type of an error reply message. */);
1810 Vdbus_message_type_error = make_number (DBUS_MESSAGE_TYPE_ERROR);
1812 DEFVAR_LISP ("dbus-message-type-signal",
1813 Vdbus_message_type_signal,
1814 doc: /* Message type of a signal message. */);
1815 Vdbus_message_type_signal = make_number (DBUS_MESSAGE_TYPE_SIGNAL);
1817 DEFVAR_LISP ("dbus-registered-objects-table",
1818 Vdbus_registered_objects_table,
1819 doc: /* Hash table of registered functions for D-Bus.
1821 There are two different uses of the hash table: for accessing
1822 registered interfaces properties, targeted by signals or method calls,
1823 and for calling handlers in case of non-blocking method call returns.
1825 In the first case, the key in the hash table is the list (TYPE BUS
1826 INTERFACE MEMBER). TYPE is one of the Lisp symbols `:method',
1827 `:signal' or `:property'. BUS is either a Lisp symbol, `:system' or
1828 `:session', or a string denoting the bus address. INTERFACE is a
1829 string which denotes a D-Bus interface, and MEMBER, also a string, is
1830 either a method, a signal or a property INTERFACE is offering. All
1831 arguments but BUS must not be nil.
1833 The value in the hash table is a list of quadruple lists \((UNAME
1834 SERVICE PATH OBJECT [RULE]) ...). SERVICE is the service name as
1835 registered, UNAME is the corresponding unique name. In case of
1836 registered methods and properties, UNAME is nil. PATH is the object
1837 path of the sending object. All of them can be nil, which means a
1838 wildcard then. OBJECT is either the handler to be called when a D-Bus
1839 message, which matches the key criteria, arrives (TYPE `:method' and
1840 `:signal'), or a cons cell containing the value of the property (TYPE
1841 `:property').
1843 For entries of type `:signal', there is also a fifth element RULE,
1844 which keeps the match string the signal is registered with.
1846 In the second case, the key in the hash table is the list (:serial BUS
1847 SERIAL). BUS is either a Lisp symbol, `:system' or `:session', or a
1848 string denoting the bus address. SERIAL is the serial number of the
1849 non-blocking method call, a reply is expected. Both arguments must
1850 not be nil. The value in the hash table is HANDLER, the function to
1851 be called when the D-Bus reply message arrives. */);
1852 Vdbus_registered_objects_table = CALLN (Fmake_hash_table, QCtest, Qequal);
1854 DEFVAR_LISP ("dbus-debug", Vdbus_debug,
1855 doc: /* If non-nil, debug messages of D-Bus bindings are raised. */);
1856 #ifdef DBUS_DEBUG
1857 Vdbus_debug = Qt;
1858 /* We can also set environment variable DBUS_VERBOSE=1 in order to
1859 see more traces. This requires libdbus-1 to be configured with
1860 --enable-verbose-mode. */
1861 #else
1862 Vdbus_debug = Qnil;
1863 #endif
1865 /* Initialize internal objects. */
1866 xd_registered_buses = Qnil;
1867 staticpro (&xd_registered_buses);
1869 Fprovide (intern_c_string ("dbusbind"), Qnil);
1873 #endif /* HAVE_DBUS */