1 /* Elisp bindings for D-Bus.
2 Copyright (C) 2007-2014 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/>. */
23 #include <dbus/dbus.h>
27 #include "termhooks.h"
31 #ifndef DBUS_NUM_MESSAGE_TYPES
32 #define DBUS_NUM_MESSAGE_TYPES 5
36 /* Some platforms define the symbol "interface", but we want to use it
37 * as a variable name below. */
45 static Lisp_Object Qdbus__init_bus
;
46 static Lisp_Object Qdbus_get_unique_name
;
47 static Lisp_Object Qdbus_message_internal
;
49 /* D-Bus error symbol. */
50 static Lisp_Object Qdbus_error
;
52 /* Lisp symbols of the system and session buses. */
53 static Lisp_Object QCdbus_system_bus
, QCdbus_session_bus
;
55 /* Lisp symbol for method call timeout. */
56 static Lisp_Object QCdbus_timeout
;
58 /* Lisp symbols of D-Bus types. */
59 static Lisp_Object QCdbus_type_byte
, QCdbus_type_boolean
;
60 static Lisp_Object QCdbus_type_int16
, QCdbus_type_uint16
;
61 static Lisp_Object QCdbus_type_int32
, QCdbus_type_uint32
;
62 static Lisp_Object QCdbus_type_int64
, QCdbus_type_uint64
;
63 static Lisp_Object QCdbus_type_double
, QCdbus_type_string
;
64 static Lisp_Object QCdbus_type_object_path
, QCdbus_type_signature
;
65 #ifdef DBUS_TYPE_UNIX_FD
66 static Lisp_Object QCdbus_type_unix_fd
;
68 static Lisp_Object QCdbus_type_array
, QCdbus_type_variant
;
69 static Lisp_Object QCdbus_type_struct
, QCdbus_type_dict_entry
;
71 /* Lisp symbols of objects in `dbus-registered-objects-table'. */
72 static Lisp_Object QCdbus_registered_serial
, QCdbus_registered_method
;
73 static Lisp_Object QCdbus_registered_signal
;
75 /* Alist of D-Bus buses we are polling for messages.
76 The key is the symbol or string of the bus, and the value is the
77 connection address. */
78 static Lisp_Object xd_registered_buses
;
80 /* Whether we are reading a D-Bus event. */
81 static bool xd_in_read_queued_messages
= 0;
84 /* We use "xd_" and "XD_" as prefix for all internal symbols, because
85 we don't want to poison other namespaces with "dbus_". */
87 /* Raise a signal. If we are reading events, we cannot signal; we
88 throw to xd_read_queued_messages then. */
89 #define XD_SIGNAL1(arg) \
91 if (xd_in_read_queued_messages) \
92 Fthrow (Qdbus_error, Qnil); \
94 xsignal1 (Qdbus_error, arg); \
97 #define XD_SIGNAL2(arg1, arg2) \
99 if (xd_in_read_queued_messages) \
100 Fthrow (Qdbus_error, Qnil); \
102 xsignal2 (Qdbus_error, arg1, arg2); \
105 #define XD_SIGNAL3(arg1, arg2, arg3) \
107 if (xd_in_read_queued_messages) \
108 Fthrow (Qdbus_error, Qnil); \
110 xsignal3 (Qdbus_error, arg1, arg2, arg3); \
113 /* Raise a Lisp error from a D-Bus ERROR. */
114 #define XD_ERROR(error) \
116 /* Remove the trailing newline. */ \
117 char const *mess = error.message; \
118 char const *nl = strchr (mess, '\n'); \
119 Lisp_Object err = make_string (mess, nl ? nl - mess : strlen (mess)); \
120 dbus_error_free (&error); \
124 /* Macros for debugging. In order to enable them, build with
125 "env MYCPPFLAGS='-DDBUS_DEBUG -Wall' make". */
127 #define XD_DEBUG_MESSAGE(...) \
130 snprintf (s, sizeof s, __VA_ARGS__); \
131 if (!noninteractive) \
132 printf ("%s: %s\n", __func__, s); \
133 message ("%s: %s", __func__, s); \
135 #define XD_DEBUG_VALID_LISP_OBJECT_P(object) \
137 if (!valid_lisp_object_p (object)) \
139 XD_DEBUG_MESSAGE ("%d Assertion failure", __LINE__); \
140 XD_SIGNAL1 (build_string ("Assertion failure")); \
144 #else /* !DBUS_DEBUG */
145 # define XD_DEBUG_MESSAGE(...) \
147 if (!NILP (Vdbus_debug)) \
150 snprintf (s, sizeof s, __VA_ARGS__); \
151 message ("%s: %s", __func__, s); \
154 # define XD_DEBUG_VALID_LISP_OBJECT_P(object)
157 /* Check whether TYPE is a basic DBusType. */
158 #ifdef HAVE_DBUS_TYPE_IS_VALID
159 #define XD_BASIC_DBUS_TYPE(type) \
160 (dbus_type_is_valid (type) && dbus_type_is_basic (type))
162 #ifdef DBUS_TYPE_UNIX_FD
163 #define XD_BASIC_DBUS_TYPE(type) \
164 ((type == DBUS_TYPE_BYTE) \
165 || (type == DBUS_TYPE_BOOLEAN) \
166 || (type == DBUS_TYPE_INT16) \
167 || (type == DBUS_TYPE_UINT16) \
168 || (type == DBUS_TYPE_INT32) \
169 || (type == DBUS_TYPE_UINT32) \
170 || (type == DBUS_TYPE_INT64) \
171 || (type == DBUS_TYPE_UINT64) \
172 || (type == DBUS_TYPE_DOUBLE) \
173 || (type == DBUS_TYPE_STRING) \
174 || (type == DBUS_TYPE_OBJECT_PATH) \
175 || (type == DBUS_TYPE_SIGNATURE) \
176 || (type == DBUS_TYPE_UNIX_FD))
178 #define XD_BASIC_DBUS_TYPE(type) \
179 ((type == DBUS_TYPE_BYTE) \
180 || (type == DBUS_TYPE_BOOLEAN) \
181 || (type == DBUS_TYPE_INT16) \
182 || (type == DBUS_TYPE_UINT16) \
183 || (type == DBUS_TYPE_INT32) \
184 || (type == DBUS_TYPE_UINT32) \
185 || (type == DBUS_TYPE_INT64) \
186 || (type == DBUS_TYPE_UINT64) \
187 || (type == DBUS_TYPE_DOUBLE) \
188 || (type == DBUS_TYPE_STRING) \
189 || (type == DBUS_TYPE_OBJECT_PATH) \
190 || (type == DBUS_TYPE_SIGNATURE))
194 /* This was a macro. On Solaris 2.11 it was said to compile for
195 hours, when optimization is enabled. So we have transferred it into
197 /* Determine the DBusType of a given Lisp symbol. OBJECT must be one
198 of the predefined D-Bus type symbols. */
200 xd_symbol_to_dbus_type (Lisp_Object object
)
203 ((EQ (object
, QCdbus_type_byte
)) ? DBUS_TYPE_BYTE
204 : (EQ (object
, QCdbus_type_boolean
)) ? DBUS_TYPE_BOOLEAN
205 : (EQ (object
, QCdbus_type_int16
)) ? DBUS_TYPE_INT16
206 : (EQ (object
, QCdbus_type_uint16
)) ? DBUS_TYPE_UINT16
207 : (EQ (object
, QCdbus_type_int32
)) ? DBUS_TYPE_INT32
208 : (EQ (object
, QCdbus_type_uint32
)) ? DBUS_TYPE_UINT32
209 : (EQ (object
, QCdbus_type_int64
)) ? DBUS_TYPE_INT64
210 : (EQ (object
, QCdbus_type_uint64
)) ? DBUS_TYPE_UINT64
211 : (EQ (object
, QCdbus_type_double
)) ? DBUS_TYPE_DOUBLE
212 : (EQ (object
, QCdbus_type_string
)) ? DBUS_TYPE_STRING
213 : (EQ (object
, QCdbus_type_object_path
)) ? DBUS_TYPE_OBJECT_PATH
214 : (EQ (object
, QCdbus_type_signature
)) ? DBUS_TYPE_SIGNATURE
215 #ifdef DBUS_TYPE_UNIX_FD
216 : (EQ (object
, QCdbus_type_unix_fd
)) ? DBUS_TYPE_UNIX_FD
218 : (EQ (object
, QCdbus_type_array
)) ? DBUS_TYPE_ARRAY
219 : (EQ (object
, QCdbus_type_variant
)) ? DBUS_TYPE_VARIANT
220 : (EQ (object
, QCdbus_type_struct
)) ? DBUS_TYPE_STRUCT
221 : (EQ (object
, QCdbus_type_dict_entry
)) ? DBUS_TYPE_DICT_ENTRY
222 : DBUS_TYPE_INVALID
);
225 /* Check whether a Lisp symbol is a predefined D-Bus type symbol. */
226 #define XD_DBUS_TYPE_P(object) \
227 (SYMBOLP (object) && ((xd_symbol_to_dbus_type (object) != DBUS_TYPE_INVALID)))
229 /* Determine the DBusType of a given Lisp OBJECT. It is used to
230 convert Lisp objects, being arguments of `dbus-call-method' or
231 `dbus-send-signal', into corresponding C values appended as
232 arguments to a D-Bus message. */
233 #define XD_OBJECT_TO_DBUS_TYPE(object) \
234 ((EQ (object, Qt) || EQ (object, Qnil)) ? DBUS_TYPE_BOOLEAN \
235 : (NATNUMP (object)) ? DBUS_TYPE_UINT32 \
236 : (INTEGERP (object)) ? DBUS_TYPE_INT32 \
237 : (FLOATP (object)) ? DBUS_TYPE_DOUBLE \
238 : (STRINGP (object)) ? DBUS_TYPE_STRING \
239 : (XD_DBUS_TYPE_P (object)) ? xd_symbol_to_dbus_type (object) \
241 ? ((XD_DBUS_TYPE_P (CAR_SAFE (object))) \
242 ? ((XD_BASIC_DBUS_TYPE (xd_symbol_to_dbus_type (CAR_SAFE (object)))) \
244 : xd_symbol_to_dbus_type (CAR_SAFE (object))) \
248 /* Return a list pointer which does not have a Lisp symbol as car. */
249 #define XD_NEXT_VALUE(object) \
250 ((XD_DBUS_TYPE_P (CAR_SAFE (object))) ? CDR_SAFE (object) : object)
252 /* Transform the message type to its string representation for debug
254 #define XD_MESSAGE_TYPE_TO_STRING(mtype) \
255 ((mtype == DBUS_MESSAGE_TYPE_INVALID) \
256 ? "DBUS_MESSAGE_TYPE_INVALID" \
257 : (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL) \
258 ? "DBUS_MESSAGE_TYPE_METHOD_CALL" \
259 : (mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN) \
260 ? "DBUS_MESSAGE_TYPE_METHOD_RETURN" \
261 : (mtype == DBUS_MESSAGE_TYPE_ERROR) \
262 ? "DBUS_MESSAGE_TYPE_ERROR" \
263 : "DBUS_MESSAGE_TYPE_SIGNAL")
265 /* Transform the object to its string representation for debug
267 #define XD_OBJECT_TO_STRING(object) \
268 SDATA (format2 ("%s", object, Qnil))
270 #define XD_DBUS_VALIDATE_BUS_ADDRESS(bus) \
272 char const *session_bus_address = getenv ("DBUS_SESSION_BUS_ADDRESS"); \
275 DBusAddressEntry **entries; \
278 dbus_error_init (&derror); \
279 if (!dbus_parse_address (SSDATA (bus), &entries, &len, &derror)) \
282 dbus_error_free (&derror); \
283 dbus_address_entries_free (entries); \
284 /* Canonicalize session bus address. */ \
285 if ((session_bus_address != NULL) \
286 && (!NILP (Fstring_equal \
287 (bus, build_string (session_bus_address))))) \
288 bus = QCdbus_session_bus; \
293 CHECK_SYMBOL (bus); \
294 if (!(EQ (bus, QCdbus_system_bus) || EQ (bus, QCdbus_session_bus))) \
295 XD_SIGNAL2 (build_string ("Wrong bus name"), bus); \
296 /* We do not want to have an autolaunch for the session bus. */ \
297 if (EQ (bus, QCdbus_session_bus) && session_bus_address == NULL) \
298 XD_SIGNAL2 (build_string ("No connection to bus"), bus); \
302 #if (HAVE_DBUS_VALIDATE_BUS_NAME || HAVE_DBUS_VALIDATE_PATH \
303 || HAVE_DBUS_VALIDATE_INTERFACE || HAVE_DBUS_VALIDATE_MEMBER)
304 #define XD_DBUS_VALIDATE_OBJECT(object, func) \
306 if (!NILP (object)) \
309 CHECK_STRING (object); \
310 dbus_error_init (&derror); \
311 if (!func (SSDATA (object), &derror)) \
314 dbus_error_free (&derror); \
319 #if HAVE_DBUS_VALIDATE_BUS_NAME
320 #define XD_DBUS_VALIDATE_BUS_NAME(bus_name) \
321 XD_DBUS_VALIDATE_OBJECT(bus_name, dbus_validate_bus_name);
323 #define XD_DBUS_VALIDATE_BUS_NAME(bus_name) \
324 if (!NILP (bus_name)) CHECK_STRING (bus_name);
327 #if HAVE_DBUS_VALIDATE_PATH
328 #define XD_DBUS_VALIDATE_PATH(path) \
329 XD_DBUS_VALIDATE_OBJECT(path, dbus_validate_path);
331 #define XD_DBUS_VALIDATE_PATH(path) \
332 if (!NILP (path)) CHECK_STRING (path);
335 #if HAVE_DBUS_VALIDATE_INTERFACE
336 #define XD_DBUS_VALIDATE_INTERFACE(interface) \
337 XD_DBUS_VALIDATE_OBJECT(interface, dbus_validate_interface);
339 #define XD_DBUS_VALIDATE_INTERFACE(interface) \
340 if (!NILP (interface)) CHECK_STRING (interface);
343 #if HAVE_DBUS_VALIDATE_MEMBER
344 #define XD_DBUS_VALIDATE_MEMBER(member) \
345 XD_DBUS_VALIDATE_OBJECT(member, dbus_validate_member);
347 #define XD_DBUS_VALIDATE_MEMBER(member) \
348 if (!NILP (member)) CHECK_STRING (member);
351 /* Append to SIGNATURE a copy of X, making sure SIGNATURE does
352 not become too long. */
354 xd_signature_cat (char *signature
, char const *x
)
356 ptrdiff_t siglen
= strlen (signature
);
357 ptrdiff_t xlen
= strlen (x
);
358 if (DBUS_MAXIMUM_SIGNATURE_LENGTH
- xlen
<= siglen
)
360 strcat (signature
, x
);
363 /* Compute SIGNATURE of OBJECT. It must have a form that it can be
364 used in dbus_message_iter_open_container. DTYPE is the DBusType
365 the object is related to. It is passed as argument, because it
366 cannot be detected in basic type objects, when they are preceded by
367 a type symbol. PARENT_TYPE is the DBusType of a container this
368 signature is embedded, or DBUS_TYPE_INVALID. It is needed for the
369 check that DBUS_TYPE_DICT_ENTRY occurs only as array element. */
371 xd_signature (char *signature
, int dtype
, int parent_type
, Lisp_Object object
)
377 char x
[DBUS_MAXIMUM_SIGNATURE_LENGTH
];
384 case DBUS_TYPE_UINT16
:
385 CHECK_NATNUM (object
);
386 sprintf (signature
, "%c", dtype
);
389 case DBUS_TYPE_BOOLEAN
:
390 if (!EQ (object
, Qt
) && !EQ (object
, Qnil
))
391 wrong_type_argument (intern ("booleanp"), object
);
392 sprintf (signature
, "%c", dtype
);
395 case DBUS_TYPE_INT16
:
396 CHECK_NUMBER (object
);
397 sprintf (signature
, "%c", dtype
);
400 case DBUS_TYPE_UINT32
:
401 case DBUS_TYPE_UINT64
:
402 #ifdef DBUS_TYPE_UNIX_FD
403 case DBUS_TYPE_UNIX_FD
:
405 case DBUS_TYPE_INT32
:
406 case DBUS_TYPE_INT64
:
407 case DBUS_TYPE_DOUBLE
:
408 CHECK_NUMBER_OR_FLOAT (object
);
409 sprintf (signature
, "%c", dtype
);
412 case DBUS_TYPE_STRING
:
413 case DBUS_TYPE_OBJECT_PATH
:
414 case DBUS_TYPE_SIGNATURE
:
415 CHECK_STRING (object
);
416 sprintf (signature
, "%c", dtype
);
419 case DBUS_TYPE_ARRAY
:
420 /* Check that all list elements have the same D-Bus type. For
421 complex element types, we just check the container type, not
422 the whole element's signature. */
425 /* Type symbol is optional. */
426 if (EQ (QCdbus_type_array
, CAR_SAFE (elt
)))
427 elt
= XD_NEXT_VALUE (elt
);
429 /* If the array is empty, DBUS_TYPE_STRING is the default
433 subtype
= DBUS_TYPE_STRING
;
434 subsig
= DBUS_TYPE_STRING_AS_STRING
;
438 subtype
= XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt
));
439 xd_signature (x
, subtype
, dtype
, CAR_SAFE (XD_NEXT_VALUE (elt
)));
443 /* If the element type is DBUS_TYPE_SIGNATURE, and this is the
444 only element, the value of this element is used as the
445 array's element signature. */
446 if ((subtype
== DBUS_TYPE_SIGNATURE
)
447 && STRINGP (CAR_SAFE (XD_NEXT_VALUE (elt
)))
448 && NILP (CDR_SAFE (XD_NEXT_VALUE (elt
))))
449 subsig
= SSDATA (CAR_SAFE (XD_NEXT_VALUE (elt
)));
453 if (subtype
!= XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt
)))
454 wrong_type_argument (intern ("D-Bus"), CAR_SAFE (elt
));
455 elt
= CDR_SAFE (XD_NEXT_VALUE (elt
));
458 subsiglen
= snprintf (signature
, DBUS_MAXIMUM_SIGNATURE_LENGTH
,
459 "%c%s", dtype
, subsig
);
460 if (! (0 <= subsiglen
&& subsiglen
< DBUS_MAXIMUM_SIGNATURE_LENGTH
))
464 case DBUS_TYPE_VARIANT
:
465 /* Check that there is exactly one list element. */
468 elt
= XD_NEXT_VALUE (elt
);
469 subtype
= XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt
));
470 xd_signature (x
, subtype
, dtype
, CAR_SAFE (XD_NEXT_VALUE (elt
)));
472 if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt
))))
473 wrong_type_argument (intern ("D-Bus"),
474 CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt
))));
476 sprintf (signature
, "%c", dtype
);
479 case DBUS_TYPE_STRUCT
:
480 /* A struct list might contain any number of elements with
481 different types. No further check needed. */
484 elt
= XD_NEXT_VALUE (elt
);
486 /* Compose the signature from the elements. It is enclosed by
488 sprintf (signature
, "%c", DBUS_STRUCT_BEGIN_CHAR
);
491 subtype
= XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt
));
492 xd_signature (x
, subtype
, dtype
, CAR_SAFE (XD_NEXT_VALUE (elt
)));
493 xd_signature_cat (signature
, x
);
494 elt
= CDR_SAFE (XD_NEXT_VALUE (elt
));
496 xd_signature_cat (signature
, DBUS_STRUCT_END_CHAR_AS_STRING
);
499 case DBUS_TYPE_DICT_ENTRY
:
500 /* Check that there are exactly two list elements, and the first
501 one is of basic type. The dictionary entry itself must be an
502 element of an array. */
505 /* Check the parent object type. */
506 if (parent_type
!= DBUS_TYPE_ARRAY
)
507 wrong_type_argument (intern ("D-Bus"), object
);
509 /* Compose the signature from the elements. It is enclosed by
511 sprintf (signature
, "%c", DBUS_DICT_ENTRY_BEGIN_CHAR
);
514 elt
= XD_NEXT_VALUE (elt
);
515 subtype
= XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt
));
516 xd_signature (x
, subtype
, dtype
, CAR_SAFE (XD_NEXT_VALUE (elt
)));
517 xd_signature_cat (signature
, x
);
519 if (!XD_BASIC_DBUS_TYPE (subtype
))
520 wrong_type_argument (intern ("D-Bus"), CAR_SAFE (XD_NEXT_VALUE (elt
)));
522 /* Second element. */
523 elt
= CDR_SAFE (XD_NEXT_VALUE (elt
));
524 subtype
= XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt
));
525 xd_signature (x
, subtype
, dtype
, CAR_SAFE (XD_NEXT_VALUE (elt
)));
526 xd_signature_cat (signature
, x
);
528 if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt
))))
529 wrong_type_argument (intern ("D-Bus"),
530 CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt
))));
532 /* Closing signature. */
533 xd_signature_cat (signature
, DBUS_DICT_ENTRY_END_CHAR_AS_STRING
);
537 wrong_type_argument (intern ("D-Bus"), object
);
540 XD_DEBUG_MESSAGE ("%s", signature
);
543 /* Convert X to a signed integer with bounds LO and HI. */
545 xd_extract_signed (Lisp_Object x
, intmax_t lo
, intmax_t hi
)
547 CHECK_NUMBER_OR_FLOAT (x
);
550 if (lo
<= XINT (x
) && XINT (x
) <= hi
)
555 double d
= XFLOAT_DATA (x
);
556 if (lo
<= d
&& d
<= hi
)
563 if (xd_in_read_queued_messages
)
564 Fthrow (Qdbus_error
, Qnil
);
566 args_out_of_range_3 (x
,
567 make_fixnum_or_float (lo
),
568 make_fixnum_or_float (hi
));
571 /* Convert X to an unsigned integer with bounds 0 and HI. */
573 xd_extract_unsigned (Lisp_Object x
, uintmax_t hi
)
575 CHECK_NUMBER_OR_FLOAT (x
);
578 if (0 <= XINT (x
) && XINT (x
) <= hi
)
583 double d
= XFLOAT_DATA (x
);
584 if (0 <= d
&& d
<= hi
)
591 if (xd_in_read_queued_messages
)
592 Fthrow (Qdbus_error
, Qnil
);
594 args_out_of_range_3 (x
, make_number (0), make_fixnum_or_float (hi
));
597 /* Append C value, extracted from Lisp OBJECT, to iteration ITER.
598 DTYPE must be a valid DBusType. It is used to convert Lisp
599 objects, being arguments of `dbus-call-method' or
600 `dbus-send-signal', into corresponding C values appended as
601 arguments to a D-Bus message. */
603 xd_append_arg (int dtype
, Lisp_Object object
, DBusMessageIter
*iter
)
605 char signature
[DBUS_MAXIMUM_SIGNATURE_LENGTH
];
606 DBusMessageIter subiter
;
608 if (XD_BASIC_DBUS_TYPE (dtype
))
612 CHECK_NATNUM (object
);
614 unsigned char val
= XFASTINT (object
) & 0xFF;
615 XD_DEBUG_MESSAGE ("%c %u", dtype
, val
);
616 if (!dbus_message_iter_append_basic (iter
, dtype
, &val
))
617 XD_SIGNAL2 (build_string ("Unable to append argument"), object
);
621 case DBUS_TYPE_BOOLEAN
:
623 dbus_bool_t val
= (NILP (object
)) ? FALSE
: TRUE
;
624 XD_DEBUG_MESSAGE ("%c %s", dtype
, (val
== FALSE
) ? "false" : "true");
625 if (!dbus_message_iter_append_basic (iter
, dtype
, &val
))
626 XD_SIGNAL2 (build_string ("Unable to append argument"), object
);
630 case DBUS_TYPE_INT16
:
633 xd_extract_signed (object
,
634 TYPE_MINIMUM (dbus_int16_t
),
635 TYPE_MAXIMUM (dbus_int16_t
));
637 XD_DEBUG_MESSAGE ("%c %d", dtype
, pval
);
638 if (!dbus_message_iter_append_basic (iter
, dtype
, &val
))
639 XD_SIGNAL2 (build_string ("Unable to append argument"), object
);
643 case DBUS_TYPE_UINT16
:
646 xd_extract_unsigned (object
,
647 TYPE_MAXIMUM (dbus_uint16_t
));
648 unsigned int pval
= val
;
649 XD_DEBUG_MESSAGE ("%c %u", dtype
, pval
);
650 if (!dbus_message_iter_append_basic (iter
, dtype
, &val
))
651 XD_SIGNAL2 (build_string ("Unable to append argument"), object
);
655 case DBUS_TYPE_INT32
:
658 xd_extract_signed (object
,
659 TYPE_MINIMUM (dbus_int32_t
),
660 TYPE_MAXIMUM (dbus_int32_t
));
662 XD_DEBUG_MESSAGE ("%c %d", dtype
, pval
);
663 if (!dbus_message_iter_append_basic (iter
, dtype
, &val
))
664 XD_SIGNAL2 (build_string ("Unable to append argument"), object
);
668 case DBUS_TYPE_UINT32
:
669 #ifdef DBUS_TYPE_UNIX_FD
670 case DBUS_TYPE_UNIX_FD
:
674 xd_extract_unsigned (object
,
675 TYPE_MAXIMUM (dbus_uint32_t
));
676 unsigned int pval
= val
;
677 XD_DEBUG_MESSAGE ("%c %u", dtype
, pval
);
678 if (!dbus_message_iter_append_basic (iter
, dtype
, &val
))
679 XD_SIGNAL2 (build_string ("Unable to append argument"), object
);
683 case DBUS_TYPE_INT64
:
686 xd_extract_signed (object
,
687 TYPE_MINIMUM (dbus_int64_t
),
688 TYPE_MAXIMUM (dbus_int64_t
));
689 printmax_t pval
= val
;
690 XD_DEBUG_MESSAGE ("%c %"pMd
, dtype
, pval
);
691 if (!dbus_message_iter_append_basic (iter
, dtype
, &val
))
692 XD_SIGNAL2 (build_string ("Unable to append argument"), object
);
696 case DBUS_TYPE_UINT64
:
699 xd_extract_unsigned (object
,
700 TYPE_MAXIMUM (dbus_uint64_t
));
701 uprintmax_t pval
= val
;
702 XD_DEBUG_MESSAGE ("%c %"pMu
, dtype
, pval
);
703 if (!dbus_message_iter_append_basic (iter
, dtype
, &val
))
704 XD_SIGNAL2 (build_string ("Unable to append argument"), object
);
708 case DBUS_TYPE_DOUBLE
:
710 double val
= extract_float (object
);
711 XD_DEBUG_MESSAGE ("%c %f", dtype
, val
);
712 if (!dbus_message_iter_append_basic (iter
, dtype
, &val
))
713 XD_SIGNAL2 (build_string ("Unable to append argument"), object
);
717 case DBUS_TYPE_STRING
:
718 case DBUS_TYPE_OBJECT_PATH
:
719 case DBUS_TYPE_SIGNATURE
:
720 CHECK_STRING (object
);
722 /* We need to send a valid UTF-8 string. We could encode `object'
723 but by not encoding it, we guarantee it's valid utf-8, even if
724 it contains eight-bit-bytes. Of course, you can still send
725 manually-crafted junk by passing a unibyte string. */
726 char *val
= SSDATA (object
);
727 XD_DEBUG_MESSAGE ("%c %s", dtype
, val
);
728 if (!dbus_message_iter_append_basic (iter
, dtype
, &val
))
729 XD_SIGNAL2 (build_string ("Unable to append argument"), object
);
734 else /* Compound types. */
737 /* All compound types except array have a type symbol. For
738 array, it is optional. Skip it. */
739 if (!XD_BASIC_DBUS_TYPE (XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object
))))
740 object
= XD_NEXT_VALUE (object
);
742 /* Open new subiteration. */
745 case DBUS_TYPE_ARRAY
:
746 /* An array has only elements of the same type. So it is
747 sufficient to check the first element's signature
751 /* If the array is empty, DBUS_TYPE_STRING is the default
753 strcpy (signature
, DBUS_TYPE_STRING_AS_STRING
);
756 /* If the element type is DBUS_TYPE_SIGNATURE, and this is
757 the only element, the value of this element is used as
758 the array's element signature. */
759 if ((XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object
))
760 == DBUS_TYPE_SIGNATURE
)
761 && STRINGP (CAR_SAFE (XD_NEXT_VALUE (object
)))
762 && NILP (CDR_SAFE (XD_NEXT_VALUE (object
))))
764 lispstpcpy (signature
, CAR_SAFE (XD_NEXT_VALUE (object
)));
765 object
= CDR_SAFE (XD_NEXT_VALUE (object
));
769 xd_signature (signature
,
770 XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object
)),
771 dtype
, CAR_SAFE (XD_NEXT_VALUE (object
)));
773 XD_DEBUG_MESSAGE ("%c %s %s", dtype
, signature
,
774 XD_OBJECT_TO_STRING (object
));
775 if (!dbus_message_iter_open_container (iter
, dtype
,
776 signature
, &subiter
))
777 XD_SIGNAL3 (build_string ("Cannot open container"),
778 make_number (dtype
), build_string (signature
));
781 case DBUS_TYPE_VARIANT
:
782 /* A variant has just one element. */
783 xd_signature (signature
, XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object
)),
784 dtype
, CAR_SAFE (XD_NEXT_VALUE (object
)));
786 XD_DEBUG_MESSAGE ("%c %s %s", dtype
, signature
,
787 XD_OBJECT_TO_STRING (object
));
788 if (!dbus_message_iter_open_container (iter
, dtype
,
789 signature
, &subiter
))
790 XD_SIGNAL3 (build_string ("Cannot open container"),
791 make_number (dtype
), build_string (signature
));
794 case DBUS_TYPE_STRUCT
:
795 case DBUS_TYPE_DICT_ENTRY
:
796 /* These containers do not require a signature. */
797 XD_DEBUG_MESSAGE ("%c %s", dtype
, XD_OBJECT_TO_STRING (object
));
798 if (!dbus_message_iter_open_container (iter
, dtype
, NULL
, &subiter
))
799 XD_SIGNAL2 (build_string ("Cannot open container"),
800 make_number (dtype
));
804 /* Loop over list elements. */
805 while (!NILP (object
))
807 dtype
= XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object
));
808 object
= XD_NEXT_VALUE (object
);
810 xd_append_arg (dtype
, CAR_SAFE (object
), &subiter
);
812 object
= CDR_SAFE (object
);
815 /* Close the subiteration. */
816 if (!dbus_message_iter_close_container (iter
, &subiter
))
817 XD_SIGNAL2 (build_string ("Cannot close container"),
818 make_number (dtype
));
822 /* Retrieve C value from a DBusMessageIter structure ITER, and return
823 a converted Lisp object. The type DTYPE of the argument of the
824 D-Bus message must be a valid DBusType. Compound D-Bus types
825 result always in a Lisp list. */
827 xd_retrieve_arg (int dtype
, DBusMessageIter
*iter
)
835 dbus_message_iter_get_basic (iter
, &val
);
837 XD_DEBUG_MESSAGE ("%c %u", dtype
, val
);
838 return make_number (val
);
841 case DBUS_TYPE_BOOLEAN
:
844 dbus_message_iter_get_basic (iter
, &val
);
845 XD_DEBUG_MESSAGE ("%c %s", dtype
, (val
== FALSE
) ? "false" : "true");
846 return (val
== FALSE
) ? Qnil
: Qt
;
849 case DBUS_TYPE_INT16
:
853 dbus_message_iter_get_basic (iter
, &val
);
855 XD_DEBUG_MESSAGE ("%c %d", dtype
, pval
);
856 return make_number (val
);
859 case DBUS_TYPE_UINT16
:
863 dbus_message_iter_get_basic (iter
, &val
);
865 XD_DEBUG_MESSAGE ("%c %d", dtype
, pval
);
866 return make_number (val
);
869 case DBUS_TYPE_INT32
:
873 dbus_message_iter_get_basic (iter
, &val
);
875 XD_DEBUG_MESSAGE ("%c %d", dtype
, pval
);
876 return make_fixnum_or_float (val
);
879 case DBUS_TYPE_UINT32
:
880 #ifdef DBUS_TYPE_UNIX_FD
881 case DBUS_TYPE_UNIX_FD
:
886 dbus_message_iter_get_basic (iter
, &val
);
888 XD_DEBUG_MESSAGE ("%c %u", dtype
, pval
);
889 return make_fixnum_or_float (val
);
892 case DBUS_TYPE_INT64
:
896 dbus_message_iter_get_basic (iter
, &val
);
898 XD_DEBUG_MESSAGE ("%c %"pMd
, dtype
, pval
);
899 return make_fixnum_or_float (val
);
902 case DBUS_TYPE_UINT64
:
906 dbus_message_iter_get_basic (iter
, &val
);
908 XD_DEBUG_MESSAGE ("%c %"pMd
, dtype
, pval
);
909 return make_fixnum_or_float (val
);
912 case DBUS_TYPE_DOUBLE
:
915 dbus_message_iter_get_basic (iter
, &val
);
916 XD_DEBUG_MESSAGE ("%c %f", dtype
, val
);
917 return make_float (val
);
920 case DBUS_TYPE_STRING
:
921 case DBUS_TYPE_OBJECT_PATH
:
922 case DBUS_TYPE_SIGNATURE
:
925 dbus_message_iter_get_basic (iter
, &val
);
926 XD_DEBUG_MESSAGE ("%c %s", dtype
, val
);
927 return build_string (val
);
930 case DBUS_TYPE_ARRAY
:
931 case DBUS_TYPE_VARIANT
:
932 case DBUS_TYPE_STRUCT
:
933 case DBUS_TYPE_DICT_ENTRY
:
937 DBusMessageIter subiter
;
941 dbus_message_iter_recurse (iter
, &subiter
);
942 while ((subtype
= dbus_message_iter_get_arg_type (&subiter
))
943 != DBUS_TYPE_INVALID
)
945 result
= Fcons (xd_retrieve_arg (subtype
, &subiter
), result
);
946 dbus_message_iter_next (&subiter
);
948 XD_DEBUG_MESSAGE ("%c %s", dtype
, XD_OBJECT_TO_STRING (result
));
949 RETURN_UNGCPRO (Fnreverse (result
));
953 XD_DEBUG_MESSAGE ("DBusType '%c' not supported", dtype
);
958 /* Return the number of references of the shared CONNECTION. */
960 xd_get_connection_references (DBusConnection
*connection
)
964 /* We cannot access the DBusConnection structure, it is not public.
965 But we know, that the reference counter is the first field in
967 refcount
= (void *) &connection
;
968 refcount
= (void *) *refcount
;
972 /* Convert a Lisp D-Bus object to a pointer. */
973 static DBusConnection
*
974 xd_lisp_dbus_to_dbus (Lisp_Object bus
)
976 return (DBusConnection
*) (intptr_t) XFASTINT (bus
);
979 /* Return D-Bus connection address. BUS is either a Lisp symbol,
980 :system or :session, or a string denoting the bus address. */
981 static DBusConnection
*
982 xd_get_connection_address (Lisp_Object bus
)
984 DBusConnection
*connection
;
987 val
= CDR_SAFE (Fassoc (bus
, xd_registered_buses
));
989 XD_SIGNAL2 (build_string ("No connection to bus"), bus
);
991 connection
= xd_lisp_dbus_to_dbus (val
);
993 if (!dbus_connection_get_is_connected (connection
))
994 XD_SIGNAL2 (build_string ("No connection to bus"), bus
);
999 /* Return the file descriptor for WATCH, -1 if not found. */
1001 xd_find_watch_fd (DBusWatch
*watch
)
1003 #if HAVE_DBUS_WATCH_GET_UNIX_FD
1004 /* TODO: Reverse these on w32, which prefers the opposite. */
1005 int fd
= dbus_watch_get_unix_fd (watch
);
1007 fd
= dbus_watch_get_socket (watch
);
1009 int fd
= dbus_watch_get_fd (watch
);
1015 static void xd_read_queued_messages (int fd
, void *data
);
1017 /* Start monitoring WATCH for possible I/O. */
1019 xd_add_watch (DBusWatch
*watch
, void *data
)
1021 unsigned int flags
= dbus_watch_get_flags (watch
);
1022 int fd
= xd_find_watch_fd (watch
);
1024 XD_DEBUG_MESSAGE ("fd %d, write %d, enabled %d",
1025 fd
, flags
& DBUS_WATCH_WRITABLE
,
1026 dbus_watch_get_enabled (watch
));
1031 if (dbus_watch_get_enabled (watch
))
1033 if (flags
& DBUS_WATCH_WRITABLE
)
1034 add_write_fd (fd
, xd_read_queued_messages
, data
);
1035 if (flags
& DBUS_WATCH_READABLE
)
1036 add_read_fd (fd
, xd_read_queued_messages
, data
);
1041 /* Stop monitoring WATCH for possible I/O.
1042 DATA is the used bus, either a string or QCdbus_system_bus or
1043 QCdbus_session_bus. */
1045 xd_remove_watch (DBusWatch
*watch
, void *data
)
1047 unsigned int flags
= dbus_watch_get_flags (watch
);
1048 int fd
= xd_find_watch_fd (watch
);
1050 XD_DEBUG_MESSAGE ("fd %d", fd
);
1055 /* Unset session environment. */
1057 if (XSYMBOL (QCdbus_session_bus
) == data
)
1059 XD_DEBUG_MESSAGE ("unsetenv DBUS_SESSION_BUS_ADDRESS");
1060 unsetenv ("DBUS_SESSION_BUS_ADDRESS");
1064 if (flags
& DBUS_WATCH_WRITABLE
)
1065 delete_write_fd (fd
);
1066 if (flags
& DBUS_WATCH_READABLE
)
1067 delete_read_fd (fd
);
1070 /* Toggle monitoring WATCH for possible I/O. */
1072 xd_toggle_watch (DBusWatch
*watch
, void *data
)
1074 if (dbus_watch_get_enabled (watch
))
1075 xd_add_watch (watch
, data
);
1077 xd_remove_watch (watch
, data
);
1080 /* Close connection to D-Bus BUS. */
1082 xd_close_bus (Lisp_Object bus
)
1084 DBusConnection
*connection
;
1088 /* Check whether we are connected. */
1089 val
= Fassoc (bus
, xd_registered_buses
);
1093 busobj
= CDR_SAFE (val
);
1094 if (NILP (busobj
)) {
1095 xd_registered_buses
= Fdelete (val
, xd_registered_buses
);
1099 /* Retrieve bus address. */
1100 connection
= xd_lisp_dbus_to_dbus (busobj
);
1102 if (xd_get_connection_references (connection
) == 1)
1104 /* Close connection, if there isn't another shared application. */
1105 XD_DEBUG_MESSAGE ("Close connection to bus %s",
1106 XD_OBJECT_TO_STRING (bus
));
1107 dbus_connection_close (connection
);
1109 xd_registered_buses
= Fdelete (val
, xd_registered_buses
);
1113 /* Decrement reference count. */
1114 dbus_connection_unref (connection
);
1120 DEFUN ("dbus--init-bus", Fdbus__init_bus
, Sdbus__init_bus
, 1, 2, 0,
1121 doc
: /* Establish the connection to D-Bus BUS.
1123 This function is dbus internal. You almost certainly want to use
1126 BUS can be either the symbol `:system' or the symbol `:session', or it
1127 can be a string denoting the address of the corresponding bus. For
1128 the system and session buses, this function is called when loading
1129 `dbus.el', there is no need to call it again.
1131 The function returns a number, which counts the connections this Emacs
1132 session has established to the BUS under the same unique name (see
1133 `dbus-get-unique-name'). It depends on the libraries Emacs is linked
1134 with, and on the environment Emacs is running. For example, if Emacs
1135 is linked with the gtk toolkit, and it runs in a GTK-aware environment
1136 like Gnome, another connection might already be established.
1138 When PRIVATE is non-nil, a new connection is established instead of
1139 reusing an existing one. It results in a new unique name at the bus.
1140 This can be used, if it is necessary to distinguish from another
1141 connection used in the same Emacs process, like the one established by
1142 GTK+. It should be used with care for at least the `:system' and
1143 `:session' buses, because other Emacs Lisp packages might already use
1144 this connection to those buses. */)
1145 (Lisp_Object bus
, Lisp_Object
private)
1147 DBusConnection
*connection
;
1152 /* Check parameter. */
1153 XD_DBUS_VALIDATE_BUS_ADDRESS (bus
);
1155 /* Close bus if it is already open. */
1158 /* Check, whether we are still connected. */
1159 val
= Fassoc (bus
, xd_registered_buses
);
1162 connection
= xd_get_connection_address (bus
);
1163 dbus_connection_ref (connection
);
1169 dbus_error_init (&derror
);
1171 /* Open the connection. */
1174 connection
= dbus_connection_open (SSDATA (bus
), &derror
);
1176 connection
= dbus_connection_open_private (SSDATA (bus
), &derror
);
1180 connection
= dbus_bus_get (EQ (bus
, QCdbus_system_bus
)
1181 ? DBUS_BUS_SYSTEM
: DBUS_BUS_SESSION
,
1184 connection
= dbus_bus_get_private (EQ (bus
, QCdbus_system_bus
)
1185 ? DBUS_BUS_SYSTEM
: DBUS_BUS_SESSION
,
1188 if (dbus_error_is_set (&derror
))
1191 if (connection
== NULL
)
1192 XD_SIGNAL2 (build_string ("No connection to bus"), bus
);
1194 /* If it is not the system or session bus, we must register
1195 ourselves. Otherwise, we have called dbus_bus_get, which has
1196 configured us to exit if the connection closes - we undo this
1199 dbus_bus_register (connection
, &derror
);
1201 dbus_connection_set_exit_on_disconnect (connection
, FALSE
);
1203 if (dbus_error_is_set (&derror
))
1206 /* Add the watch functions. We pass also the bus as data, in
1207 order to distinguish between the buses in xd_remove_watch. */
1208 if (!dbus_connection_set_watch_functions (connection
,
1213 ? (void *) XSYMBOL (bus
)
1214 : (void *) XSTRING (bus
),
1216 XD_SIGNAL1 (build_string ("Cannot add watch functions"));
1218 /* Add bus to list of registered buses. */
1219 XSETFASTINT (val
, (intptr_t) connection
);
1220 xd_registered_buses
= Fcons (Fcons (bus
, val
), xd_registered_buses
);
1222 /* We do not want to abort. */
1223 xputenv ("DBUS_FATAL_WARNINGS=0");
1226 dbus_error_free (&derror
);
1229 /* Return reference counter. */
1230 refcount
= xd_get_connection_references (connection
);
1231 XD_DEBUG_MESSAGE ("Bus %s, Reference counter %"pD
"d",
1232 XD_OBJECT_TO_STRING (bus
), refcount
);
1233 return make_number (refcount
);
1236 DEFUN ("dbus-get-unique-name", Fdbus_get_unique_name
, Sdbus_get_unique_name
,
1238 doc
: /* Return the unique name of Emacs registered at D-Bus BUS. */)
1241 DBusConnection
*connection
;
1244 /* Check parameter. */
1245 XD_DBUS_VALIDATE_BUS_ADDRESS (bus
);
1247 /* Retrieve bus address. */
1248 connection
= xd_get_connection_address (bus
);
1250 /* Request the name. */
1251 name
= dbus_bus_get_unique_name (connection
);
1253 XD_SIGNAL1 (build_string ("No unique name available"));
1256 return build_string (name
);
1259 DEFUN ("dbus-message-internal", Fdbus_message_internal
, Sdbus_message_internal
,
1261 doc
: /* Send a D-Bus message.
1262 This is an internal function, it shall not be used outside dbus.el.
1264 The following usages are expected:
1266 `dbus-call-method', `dbus-call-method-asynchronously':
1267 \(dbus-message-internal
1268 dbus-message-type-method-call BUS SERVICE PATH INTERFACE METHOD HANDLER
1269 &optional :timeout TIMEOUT &rest ARGS)
1272 \(dbus-message-internal
1273 dbus-message-type-signal BUS SERVICE PATH INTERFACE SIGNAL &rest ARGS)
1275 `dbus-method-return-internal':
1276 \(dbus-message-internal
1277 dbus-message-type-method-return BUS SERVICE SERIAL &rest ARGS)
1279 `dbus-method-error-internal':
1280 \(dbus-message-internal
1281 dbus-message-type-error BUS SERVICE SERIAL &rest ARGS)
1283 usage: (dbus-message-internal &rest REST) */)
1284 (ptrdiff_t nargs
, Lisp_Object
*args
)
1286 Lisp_Object message_type
, bus
, service
, handler
;
1287 Lisp_Object path
= Qnil
;
1288 Lisp_Object interface
= Qnil
;
1289 Lisp_Object member
= Qnil
;
1291 struct gcpro gcpro1
, gcpro2
, gcpro3
, gcpro4
, gcpro5
, gcpro6
;
1292 DBusConnection
*connection
;
1293 DBusMessage
*dmessage
;
1294 DBusMessageIter iter
;
1297 dbus_uint32_t serial
= 0;
1298 unsigned int ui_serial
;
1301 char signature
[DBUS_MAXIMUM_SIGNATURE_LENGTH
];
1303 /* Initialize parameters. */
1304 message_type
= args
[0];
1309 CHECK_NATNUM (message_type
);
1310 if (! (DBUS_MESSAGE_TYPE_INVALID
< XFASTINT (message_type
)
1311 && XFASTINT (message_type
) < DBUS_NUM_MESSAGE_TYPES
))
1312 XD_SIGNAL2 (build_string ("Invalid message type"), message_type
);
1313 mtype
= XFASTINT (message_type
);
1315 if ((mtype
== DBUS_MESSAGE_TYPE_METHOD_CALL
)
1316 || (mtype
== DBUS_MESSAGE_TYPE_SIGNAL
))
1319 interface
= args
[4];
1321 if (mtype
== DBUS_MESSAGE_TYPE_METHOD_CALL
)
1323 count
= (mtype
== DBUS_MESSAGE_TYPE_METHOD_CALL
) ? 7 : 6;
1325 else /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR */
1327 serial
= xd_extract_unsigned (args
[3], TYPE_MAXIMUM (dbus_uint32_t
));
1331 /* Check parameters. */
1332 XD_DBUS_VALIDATE_BUS_ADDRESS (bus
);
1333 XD_DBUS_VALIDATE_BUS_NAME (service
);
1335 xsignal2 (Qwrong_number_of_arguments
,
1336 Qdbus_message_internal
,
1337 make_number (nargs
));
1339 if ((mtype
== DBUS_MESSAGE_TYPE_METHOD_CALL
)
1340 || (mtype
== DBUS_MESSAGE_TYPE_SIGNAL
))
1342 XD_DBUS_VALIDATE_PATH (path
);
1343 XD_DBUS_VALIDATE_INTERFACE (interface
);
1344 XD_DBUS_VALIDATE_MEMBER (member
);
1345 if (!NILP (handler
) && (!FUNCTIONP (handler
)))
1346 wrong_type_argument (Qinvalid_function
, handler
);
1349 /* Protect Lisp variables. */
1350 GCPRO6 (bus
, service
, path
, interface
, member
, handler
);
1352 /* Trace parameters. */
1355 case DBUS_MESSAGE_TYPE_METHOD_CALL
:
1356 XD_DEBUG_MESSAGE ("%s %s %s %s %s %s %s",
1357 XD_MESSAGE_TYPE_TO_STRING (mtype
),
1358 XD_OBJECT_TO_STRING (bus
),
1359 XD_OBJECT_TO_STRING (service
),
1360 XD_OBJECT_TO_STRING (path
),
1361 XD_OBJECT_TO_STRING (interface
),
1362 XD_OBJECT_TO_STRING (member
),
1363 XD_OBJECT_TO_STRING (handler
));
1365 case DBUS_MESSAGE_TYPE_SIGNAL
:
1366 XD_DEBUG_MESSAGE ("%s %s %s %s %s %s",
1367 XD_MESSAGE_TYPE_TO_STRING (mtype
),
1368 XD_OBJECT_TO_STRING (bus
),
1369 XD_OBJECT_TO_STRING (service
),
1370 XD_OBJECT_TO_STRING (path
),
1371 XD_OBJECT_TO_STRING (interface
),
1372 XD_OBJECT_TO_STRING (member
));
1374 default: /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR */
1376 XD_DEBUG_MESSAGE ("%s %s %s %u",
1377 XD_MESSAGE_TYPE_TO_STRING (mtype
),
1378 XD_OBJECT_TO_STRING (bus
),
1379 XD_OBJECT_TO_STRING (service
),
1383 /* Retrieve bus address. */
1384 connection
= xd_get_connection_address (bus
);
1386 /* Create the D-Bus message. */
1387 dmessage
= dbus_message_new (mtype
);
1388 if (dmessage
== NULL
)
1391 XD_SIGNAL1 (build_string ("Unable to create a new message"));
1394 if (STRINGP (service
))
1396 if (mtype
!= DBUS_MESSAGE_TYPE_SIGNAL
)
1397 /* Set destination. */
1399 if (!dbus_message_set_destination (dmessage
, SSDATA (service
)))
1402 XD_SIGNAL2 (build_string ("Unable to set the destination"),
1408 /* Set destination for unicast signals. */
1412 /* If it is the same unique name as we are registered at the
1413 bus or an unknown name, we regard it as broadcast message
1414 due to backward compatibility. */
1415 if (dbus_bus_name_has_owner (connection
, SSDATA (service
), NULL
))
1416 uname
= call2 (intern ("dbus-get-name-owner"), bus
, service
);
1421 && (strcmp (dbus_bus_get_unique_name (connection
), SSDATA (uname
))
1423 && (!dbus_message_set_destination (dmessage
, SSDATA (service
))))
1426 XD_SIGNAL2 (build_string ("Unable to set signal destination"),
1432 /* Set message parameters. */
1433 if ((mtype
== DBUS_MESSAGE_TYPE_METHOD_CALL
)
1434 || (mtype
== DBUS_MESSAGE_TYPE_SIGNAL
))
1436 if ((!dbus_message_set_path (dmessage
, SSDATA (path
)))
1437 || (!dbus_message_set_interface (dmessage
, SSDATA (interface
)))
1438 || (!dbus_message_set_member (dmessage
, SSDATA (member
))))
1441 XD_SIGNAL1 (build_string ("Unable to set the message parameter"));
1445 else /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR */
1447 if (!dbus_message_set_reply_serial (dmessage
, serial
))
1450 XD_SIGNAL1 (build_string ("Unable to create a return message"));
1453 if ((mtype
== DBUS_MESSAGE_TYPE_ERROR
)
1454 && (!dbus_message_set_error_name (dmessage
, DBUS_ERROR_FAILED
)))
1457 XD_SIGNAL1 (build_string ("Unable to create a error message"));
1461 /* Check for timeout parameter. */
1462 if ((count
+2 <= nargs
) && (EQ ((args
[count
]), QCdbus_timeout
)))
1464 CHECK_NATNUM (args
[count
+1]);
1465 timeout
= min (XFASTINT (args
[count
+1]), INT_MAX
);
1469 /* Initialize parameter list of message. */
1470 dbus_message_iter_init_append (dmessage
, &iter
);
1472 /* Append parameters to the message. */
1473 for (; count
< nargs
; ++count
)
1475 dtype
= XD_OBJECT_TO_DBUS_TYPE (args
[count
]);
1476 if (XD_DBUS_TYPE_P (args
[count
]))
1478 XD_DEBUG_VALID_LISP_OBJECT_P (args
[count
]);
1479 XD_DEBUG_VALID_LISP_OBJECT_P (args
[count
+1]);
1480 XD_DEBUG_MESSAGE ("Parameter%"pD
"d %s %s", count
- 4,
1481 XD_OBJECT_TO_STRING (args
[count
]),
1482 XD_OBJECT_TO_STRING (args
[count
+1]));
1487 XD_DEBUG_VALID_LISP_OBJECT_P (args
[count
]);
1488 XD_DEBUG_MESSAGE ("Parameter%"pD
"d %s", count
- 4,
1489 XD_OBJECT_TO_STRING (args
[count
]));
1492 /* Check for valid signature. We use DBUS_TYPE_INVALID as
1493 indication that there is no parent type. */
1494 xd_signature (signature
, dtype
, DBUS_TYPE_INVALID
, args
[count
]);
1496 xd_append_arg (dtype
, args
[count
], &iter
);
1499 if (!NILP (handler
))
1501 /* Send the message. The message is just added to the outgoing
1503 if (!dbus_connection_send_with_reply (connection
, dmessage
,
1507 XD_SIGNAL1 (build_string ("Cannot send message"));
1510 /* The result is the key in Vdbus_registered_objects_table. */
1511 serial
= dbus_message_get_serial (dmessage
);
1512 result
= list3 (QCdbus_registered_serial
,
1513 bus
, make_fixnum_or_float (serial
));
1515 /* Create a hash table entry. */
1516 Fputhash (result
, handler
, Vdbus_registered_objects_table
);
1520 /* Send the message. The message is just added to the outgoing
1522 if (!dbus_connection_send (connection
, dmessage
, NULL
))
1525 XD_SIGNAL1 (build_string ("Cannot send message"));
1531 XD_DEBUG_MESSAGE ("Message sent: %s", XD_OBJECT_TO_STRING (result
));
1534 dbus_message_unref (dmessage
);
1536 /* Return the result. */
1537 RETURN_UNGCPRO (result
);
1540 /* Read one queued incoming message of the D-Bus BUS.
1541 BUS is either a Lisp symbol, :system or :session, or a string denoting
1544 xd_read_message_1 (DBusConnection
*connection
, Lisp_Object bus
)
1546 Lisp_Object args
, key
, value
;
1547 struct gcpro gcpro1
;
1548 struct input_event event
;
1549 DBusMessage
*dmessage
;
1550 DBusMessageIter iter
;
1553 dbus_uint32_t serial
;
1554 unsigned int ui_serial
;
1555 const char *uname
, *path
, *interface
, *member
;
1557 dmessage
= dbus_connection_pop_message (connection
);
1559 /* Return if there is no queued message. */
1560 if (dmessage
== NULL
)
1563 /* Collect the parameters. */
1567 /* Loop over the resulting parameters. Construct a list. */
1568 if (dbus_message_iter_init (dmessage
, &iter
))
1570 while ((dtype
= dbus_message_iter_get_arg_type (&iter
))
1571 != DBUS_TYPE_INVALID
)
1573 args
= Fcons (xd_retrieve_arg (dtype
, &iter
), args
);
1574 dbus_message_iter_next (&iter
);
1576 /* The arguments are stored in reverse order. Reorder them. */
1577 args
= Fnreverse (args
);
1580 /* Read message type, message serial, unique name, object path,
1581 interface and member from the message. */
1582 mtype
= dbus_message_get_type (dmessage
);
1583 ui_serial
= serial
=
1584 ((mtype
== DBUS_MESSAGE_TYPE_METHOD_RETURN
)
1585 || (mtype
== DBUS_MESSAGE_TYPE_ERROR
))
1586 ? dbus_message_get_reply_serial (dmessage
)
1587 : dbus_message_get_serial (dmessage
);
1588 uname
= dbus_message_get_sender (dmessage
);
1589 path
= dbus_message_get_path (dmessage
);
1590 interface
= dbus_message_get_interface (dmessage
);
1591 member
= dbus_message_get_member (dmessage
);
1593 XD_DEBUG_MESSAGE ("Event received: %s %u %s %s %s %s %s",
1594 XD_MESSAGE_TYPE_TO_STRING (mtype
),
1595 ui_serial
, uname
, path
, interface
, member
,
1596 XD_OBJECT_TO_STRING (args
));
1598 if (mtype
== DBUS_MESSAGE_TYPE_INVALID
)
1601 else if ((mtype
== DBUS_MESSAGE_TYPE_METHOD_RETURN
)
1602 || (mtype
== DBUS_MESSAGE_TYPE_ERROR
))
1604 /* Search for a registered function of the message. */
1605 key
= list3 (QCdbus_registered_serial
, bus
,
1606 make_fixnum_or_float (serial
));
1607 value
= Fgethash (key
, Vdbus_registered_objects_table
, Qnil
);
1609 /* There shall be exactly one entry. Construct an event. */
1613 /* Remove the entry. */
1614 Fremhash (key
, Vdbus_registered_objects_table
);
1616 /* Construct an event. */
1618 event
.kind
= DBUS_EVENT
;
1619 event
.frame_or_window
= Qnil
;
1620 event
.arg
= Fcons (value
, args
);
1623 else /* DBUS_MESSAGE_TYPE_METHOD_CALL, DBUS_MESSAGE_TYPE_SIGNAL. */
1625 /* Vdbus_registered_objects_table requires non-nil interface and
1627 if ((interface
== NULL
) || (member
== NULL
))
1630 /* Search for a registered function of the message. */
1631 key
= list4 ((mtype
== DBUS_MESSAGE_TYPE_METHOD_CALL
)
1632 ? QCdbus_registered_method
1633 : QCdbus_registered_signal
,
1634 bus
, build_string (interface
), build_string (member
));
1635 value
= Fgethash (key
, Vdbus_registered_objects_table
, Qnil
);
1637 /* Loop over the registered functions. Construct an event. */
1638 while (!NILP (value
))
1640 key
= CAR_SAFE (value
);
1641 /* key has the structure (UNAME SERVICE PATH HANDLER). */
1642 if (((uname
== NULL
)
1643 || (NILP (CAR_SAFE (key
)))
1644 || (strcmp (uname
, SSDATA (CAR_SAFE (key
))) == 0))
1646 || (NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (key
)))))
1648 SSDATA (CAR_SAFE (CDR_SAFE (CDR_SAFE (key
)))))
1650 && (!NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key
)))))))
1653 event
.kind
= DBUS_EVENT
;
1654 event
.frame_or_window
= Qnil
;
1656 = Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key
)))), args
);
1659 value
= CDR_SAFE (value
);
1666 /* Add type, serial, uname, path, interface and member to the event. */
1667 event
.arg
= Fcons ((member
== NULL
? Qnil
: build_string (member
)),
1669 event
.arg
= Fcons ((interface
== NULL
? Qnil
: build_string (interface
)),
1671 event
.arg
= Fcons ((path
== NULL
? Qnil
: build_string (path
)),
1673 event
.arg
= Fcons ((uname
== NULL
? Qnil
: build_string (uname
)),
1675 event
.arg
= Fcons (make_fixnum_or_float (serial
), event
.arg
);
1676 event
.arg
= Fcons (make_number (mtype
), event
.arg
);
1678 /* Add the bus symbol to the event. */
1679 event
.arg
= Fcons (bus
, event
.arg
);
1681 /* Store it into the input event queue. */
1682 kbd_buffer_store_event (&event
);
1684 XD_DEBUG_MESSAGE ("Event stored: %s", XD_OBJECT_TO_STRING (event
.arg
));
1688 dbus_message_unref (dmessage
);
1693 /* Read queued incoming messages of the D-Bus BUS.
1694 BUS is either a Lisp symbol, :system or :session, or a string denoting
1697 xd_read_message (Lisp_Object bus
)
1699 /* Retrieve bus address. */
1700 DBusConnection
*connection
= xd_get_connection_address (bus
);
1702 /* Non blocking read of the next available message. */
1703 dbus_connection_read_write (connection
, 0);
1705 while (dbus_connection_get_dispatch_status (connection
)
1706 != DBUS_DISPATCH_COMPLETE
)
1707 xd_read_message_1 (connection
, bus
);
1711 /* Callback called when something is ready to read or write. */
1713 xd_read_queued_messages (int fd
, void *data
)
1715 Lisp_Object busp
= xd_registered_buses
;
1716 Lisp_Object bus
= Qnil
;
1719 /* Find bus related to fd. */
1721 while (!NILP (busp
))
1723 key
= CAR_SAFE (CAR_SAFE (busp
));
1724 if ((SYMBOLP (key
) && XSYMBOL (key
) == data
)
1725 || (STRINGP (key
) && XSTRING (key
) == data
))
1727 busp
= CDR_SAFE (busp
);
1733 /* We ignore all Lisp errors during the call. */
1734 xd_in_read_queued_messages
= 1;
1735 internal_catch (Qdbus_error
, xd_read_message
, bus
);
1736 xd_in_read_queued_messages
= 0;
1741 syms_of_dbusbind (void)
1744 DEFSYM (Qdbus__init_bus
, "dbus--init-bus");
1745 defsubr (&Sdbus__init_bus
);
1747 DEFSYM (Qdbus_get_unique_name
, "dbus-get-unique-name");
1748 defsubr (&Sdbus_get_unique_name
);
1750 DEFSYM (Qdbus_message_internal
, "dbus-message-internal");
1751 defsubr (&Sdbus_message_internal
);
1753 DEFSYM (Qdbus_error
, "dbus-error");
1754 Fput (Qdbus_error
, Qerror_conditions
,
1755 list2 (Qdbus_error
, Qerror
));
1756 Fput (Qdbus_error
, Qerror_message
,
1757 build_pure_c_string ("D-Bus error"));
1759 DEFSYM (QCdbus_system_bus
, ":system");
1760 DEFSYM (QCdbus_session_bus
, ":session");
1761 DEFSYM (QCdbus_timeout
, ":timeout");
1762 DEFSYM (QCdbus_type_byte
, ":byte");
1763 DEFSYM (QCdbus_type_boolean
, ":boolean");
1764 DEFSYM (QCdbus_type_int16
, ":int16");
1765 DEFSYM (QCdbus_type_uint16
, ":uint16");
1766 DEFSYM (QCdbus_type_int32
, ":int32");
1767 DEFSYM (QCdbus_type_uint32
, ":uint32");
1768 DEFSYM (QCdbus_type_int64
, ":int64");
1769 DEFSYM (QCdbus_type_uint64
, ":uint64");
1770 DEFSYM (QCdbus_type_double
, ":double");
1771 DEFSYM (QCdbus_type_string
, ":string");
1772 DEFSYM (QCdbus_type_object_path
, ":object-path");
1773 DEFSYM (QCdbus_type_signature
, ":signature");
1774 #ifdef DBUS_TYPE_UNIX_FD
1775 DEFSYM (QCdbus_type_unix_fd
, ":unix-fd");
1777 DEFSYM (QCdbus_type_array
, ":array");
1778 DEFSYM (QCdbus_type_variant
, ":variant");
1779 DEFSYM (QCdbus_type_struct
, ":struct");
1780 DEFSYM (QCdbus_type_dict_entry
, ":dict-entry");
1781 DEFSYM (QCdbus_registered_serial
, ":serial");
1782 DEFSYM (QCdbus_registered_method
, ":method");
1783 DEFSYM (QCdbus_registered_signal
, ":signal");
1785 DEFVAR_LISP ("dbus-compiled-version",
1786 Vdbus_compiled_version
,
1787 doc
: /* The version of D-Bus Emacs is compiled against. */);
1788 #ifdef DBUS_VERSION_STRING
1789 Vdbus_compiled_version
= build_pure_c_string (DBUS_VERSION_STRING
);
1791 Vdbus_compiled_version
= Qnil
;
1794 DEFVAR_LISP ("dbus-runtime-version",
1795 Vdbus_runtime_version
,
1796 doc
: /* The version of D-Bus Emacs runs with. */);
1799 int major
, minor
, micro
;
1800 char s
[sizeof ".." + 3 * INT_STRLEN_BOUND (int)];
1801 dbus_get_version (&major
, &minor
, µ
);
1802 Vdbus_runtime_version
1803 = make_formatted_string (s
, "%d.%d.%d", major
, minor
, micro
);
1805 Vdbus_runtime_version
= Qnil
;
1809 DEFVAR_LISP ("dbus-message-type-invalid",
1810 Vdbus_message_type_invalid
,
1811 doc
: /* This value is never a valid message type. */);
1812 Vdbus_message_type_invalid
= make_number (DBUS_MESSAGE_TYPE_INVALID
);
1814 DEFVAR_LISP ("dbus-message-type-method-call",
1815 Vdbus_message_type_method_call
,
1816 doc
: /* Message type of a method call message. */);
1817 Vdbus_message_type_method_call
= make_number (DBUS_MESSAGE_TYPE_METHOD_CALL
);
1819 DEFVAR_LISP ("dbus-message-type-method-return",
1820 Vdbus_message_type_method_return
,
1821 doc
: /* Message type of a method return message. */);
1822 Vdbus_message_type_method_return
1823 = make_number (DBUS_MESSAGE_TYPE_METHOD_RETURN
);
1825 DEFVAR_LISP ("dbus-message-type-error",
1826 Vdbus_message_type_error
,
1827 doc
: /* Message type of an error reply message. */);
1828 Vdbus_message_type_error
= make_number (DBUS_MESSAGE_TYPE_ERROR
);
1830 DEFVAR_LISP ("dbus-message-type-signal",
1831 Vdbus_message_type_signal
,
1832 doc
: /* Message type of a signal message. */);
1833 Vdbus_message_type_signal
= make_number (DBUS_MESSAGE_TYPE_SIGNAL
);
1835 DEFVAR_LISP ("dbus-registered-objects-table",
1836 Vdbus_registered_objects_table
,
1837 doc
: /* Hash table of registered functions for D-Bus.
1839 There are two different uses of the hash table: for accessing
1840 registered interfaces properties, targeted by signals or method calls,
1841 and for calling handlers in case of non-blocking method call returns.
1843 In the first case, the key in the hash table is the list (TYPE BUS
1844 INTERFACE MEMBER). TYPE is one of the Lisp symbols `:method',
1845 `:signal' or `:property'. BUS is either a Lisp symbol, `:system' or
1846 `:session', or a string denoting the bus address. INTERFACE is a
1847 string which denotes a D-Bus interface, and MEMBER, also a string, is
1848 either a method, a signal or a property INTERFACE is offering. All
1849 arguments but BUS must not be nil.
1851 The value in the hash table is a list of quadruple lists \((UNAME
1852 SERVICE PATH OBJECT [RULE]) ...). SERVICE is the service name as
1853 registered, UNAME is the corresponding unique name. In case of
1854 registered methods and properties, UNAME is nil. PATH is the object
1855 path of the sending object. All of them can be nil, which means a
1856 wildcard then. OBJECT is either the handler to be called when a D-Bus
1857 message, which matches the key criteria, arrives (TYPE `:method' and
1858 `:signal'), or a cons cell containing the value of the property (TYPE
1861 For entries of type `:signal', there is also a fifth element RULE,
1862 which keeps the match string the signal is registered with.
1864 In the second case, the key in the hash table is the list (:serial BUS
1865 SERIAL). BUS is either a Lisp symbol, `:system' or `:session', or a
1866 string denoting the bus address. SERIAL is the serial number of the
1867 non-blocking method call, a reply is expected. Both arguments must
1868 not be nil. The value in the hash table is HANDLER, the function to
1869 be called when the D-Bus reply message arrives. */);
1871 Lisp_Object args
[2];
1874 Vdbus_registered_objects_table
= Fmake_hash_table (2, args
);
1877 DEFVAR_LISP ("dbus-debug", Vdbus_debug
,
1878 doc
: /* If non-nil, debug messages of D-Bus bindings are raised. */);
1881 /* We can also set environment variable DBUS_VERBOSE=1 in order to
1882 see more traces. This requires libdbus-1 to be configured with
1883 --enable-verbose-mode. */
1888 /* Initialize internal objects. */
1889 xd_registered_buses
= Qnil
;
1890 staticpro (&xd_registered_buses
);
1892 Fprovide (intern_c_string ("dbusbind"), Qnil
);
1896 #endif /* HAVE_DBUS */