root/src/dbusbind.c

DEFINITIONS

1. xd_symbol_to_dbus_type
2. xd_dbus_type_to_symbol
3. XD_OBJECT_TO_STRING
4. xd_signature_cat
5. xd_signature
6. xd_extract_signed
7. xd_extract_unsigned
8. xd_append_arg
9. xd_retrieve_arg
10. xd_get_connection_references
11. xd_lisp_dbus_to_dbus
12. xd_get_connection_address
13. xd_find_watch_fd
14. xd_add_watch
15. xd_remove_watch
16. xd_toggle_watch
17. xd_close_bus
18. DEFUN
19. xd_read_message_1
20. xd_read_message
21. xd_read_queued_messages
22. init_dbusbind
23. syms_of_dbusbind_for_pdumper
24. syms_of_dbusbind

     1 /* Elisp bindings for D-Bus.
     2    Copyright (C) 2007-2023 Free Software Foundation, Inc.
     3 
     4 This file is part of GNU Emacs.
     5 
     6 GNU Emacs is free software: you can redistribute it and/or modify
     7 it under the terms of the GNU General Public License as published by
     8 the Free Software Foundation, either version 3 of the License, or (at
     9 your option) any later version.
    10 
    11 GNU Emacs is distributed in the hope that it will be useful,
    12 but WITHOUT ANY WARRANTY; without even the implied warranty of
    13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    14 GNU General Public License for more details.
    15 
    16 You should have received a copy of the GNU General Public License
    17 along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.  */
    18 
    19 #include <config.h>
    20 
    21 #ifdef HAVE_DBUS
    22 #include <stdio.h>
    23 #include <stdlib.h>
    24 #include <dbus/dbus.h>
    25 
    26 #include "lisp.h"
    27 #include "termhooks.h"
    28 #include "keyboard.h"
    29 #include "pdumper.h"
    30 #include "process.h"
    31 
    32 #ifndef DBUS_NUM_MESSAGE_TYPES
    33 #define DBUS_NUM_MESSAGE_TYPES 5
    34 #endif
    35 
    36 
    37 /* Some platforms define the symbol "interface", but we want to use it
    38  * as a variable name below.  */
    39 
    40 #ifdef interface
    41 #undef interface
    42 #endif
    43 
    44 
    45 /* Alist of D-Bus buses we are polling for messages.
    46    The key is the symbol or string of the bus, and the value is the
    47    connection address.  For every bus, just one connection is counted.
    48    If there shall be a second connection to the same bus, a different
    49    symbol or string for the bus must be chosen.  On Lisp level, a bus
    50    stands for the associated connection.  */
    51 static Lisp_Object xd_registered_buses;
    52 
    53 /* Whether we are reading a D-Bus event.  */
    54 static bool xd_in_read_queued_messages = 0;
    55 
    56 
    57 /* We use "xd_" and "XD_" as prefix for all internal symbols, because
    58    we don't want to poison other namespaces with "dbus_".  */
    59 
    60 /* Raise a signal.  If we are reading events, we cannot signal; we
    61    throw to xd_read_queued_messages then.  */
    62 #define XD_SIGNAL1(arg)                                                 \
    63   do {                                                                  \
    64     if (xd_in_read_queued_messages)                                     \
    65       Fthrow (Qdbus_error, Qnil);                                       \
    66     else                                                                \
    67       xsignal1 (Qdbus_error, arg);                                      \
    68   } while (0)
    69 
    70 #define XD_SIGNAL2(arg1, arg2)                                          \
    71   do {                                                                  \
    72     if (xd_in_read_queued_messages)                                     \
    73       Fthrow (Qdbus_error, Qnil);                                       \
    74     else                                                                \
    75       xsignal2 (Qdbus_error, arg1, arg2);                               \
    76   } while (0)
    77 
    78 #define XD_SIGNAL3(arg1, arg2, arg3)                                    \
    79   do {                                                                  \
    80     if (xd_in_read_queued_messages)                                     \
    81       Fthrow (Qdbus_error, Qnil);                                       \
    82     else                                                                \
    83       xsignal3 (Qdbus_error, arg1, arg2, arg3);                         \
    84   } while (0)
    85 
    86 /* Raise a Lisp error from a D-Bus ERROR.  */
    87 #define XD_ERROR(error)                                                 \
    88   do {                                                                  \
    89     /* Remove the trailing newline.  */                                 \
    90     char const *mess = error.message;                                   \
    91     char const *nl = strchr (mess, '\n');                               \
    92     Lisp_Object err = make_string (mess, nl ? nl - mess : strlen (mess)); \
    93     dbus_error_free (&error);                                           \
    94     XD_SIGNAL1 (err);                                                   \
    95   } while (0)
    96 
    97 /* Macros for debugging.  In order to enable them, build with
    98    "make MYCPPFLAGS='-DDBUS_DEBUG'".  */
    99 #ifdef DBUS_DEBUG
   100 #define XD_DEBUG_MESSAGE(...)                                           \
   101   do {                                                                  \
   102     char s[1024];                                                       \
   103     snprintf (s, sizeof s, __VA_ARGS__);                                \
   104     if (!noninteractive)                                                \
   105       printf ("%s: %s\n", __func__, s);                                 \
   106     message ("%s: %s", __func__, s);                                    \
   107   } while (0)
   108 #define XD_DEBUG_VALID_LISP_OBJECT_P(object)                            \
   109   do {                                                                  \
   110     if (!valid_lisp_object_p (object))                                  \
   111       {                                                                 \
   112         XD_DEBUG_MESSAGE ("%d Assertion failure", __LINE__);            \
   113         XD_SIGNAL1 (build_string ("Assertion failure"));                \
   114       }                                                                 \
   115   } while (0)
   116 
   117 #else /* !DBUS_DEBUG */
   118 # define XD_DEBUG_MESSAGE(...)                                          \
   119   do {                                                                  \
   120     if (!NILP (Vdbus_debug))                                            \
   121       {                                                                 \
   122         char s[1024];                                                   \
   123         snprintf (s, sizeof s, __VA_ARGS__);                            \
   124         message ("%s: %s", __func__, s);                                \
   125       }                                                                 \
   126   } while (0)
   127 # define XD_DEBUG_VALID_LISP_OBJECT_P(object)
   128 #endif
   129 
   130 /* Check whether TYPE is a basic DBusType.  */
   131 #ifdef HAVE_DBUS_TYPE_IS_VALID
   132 #define XD_BASIC_DBUS_TYPE(type)                                        \
   133   (dbus_type_is_valid (type) && dbus_type_is_basic (type))
   134 #else
   135 #ifdef DBUS_TYPE_UNIX_FD
   136 #define XD_BASIC_DBUS_TYPE(type)                                        \
   137   ((type ==  DBUS_TYPE_BYTE)                                            \
   138    || (type ==  DBUS_TYPE_BOOLEAN)                                      \
   139    || (type ==  DBUS_TYPE_INT16)                                        \
   140    || (type ==  DBUS_TYPE_UINT16)                                       \
   141    || (type ==  DBUS_TYPE_INT32)                                        \
   142    || (type ==  DBUS_TYPE_UINT32)                                       \
   143    || (type ==  DBUS_TYPE_INT64)                                        \
   144    || (type ==  DBUS_TYPE_UINT64)                                       \
   145    || (type ==  DBUS_TYPE_DOUBLE)                                       \
   146    || (type ==  DBUS_TYPE_STRING)                                       \
   147    || (type ==  DBUS_TYPE_OBJECT_PATH)                                  \
   148    || (type ==  DBUS_TYPE_SIGNATURE)                                    \
   149    || (type ==  DBUS_TYPE_UNIX_FD))
   150 #else
   151 #define XD_BASIC_DBUS_TYPE(type)                                        \
   152   ((type ==  DBUS_TYPE_BYTE)                                            \
   153    || (type ==  DBUS_TYPE_BOOLEAN)                                      \
   154    || (type ==  DBUS_TYPE_INT16)                                        \
   155    || (type ==  DBUS_TYPE_UINT16)                                       \
   156    || (type ==  DBUS_TYPE_INT32)                                        \
   157    || (type ==  DBUS_TYPE_UINT32)                                       \
   158    || (type ==  DBUS_TYPE_INT64)                                        \
   159    || (type ==  DBUS_TYPE_UINT64)                                       \
   160    || (type ==  DBUS_TYPE_DOUBLE)                                       \
   161    || (type ==  DBUS_TYPE_STRING)                                       \
   162    || (type ==  DBUS_TYPE_OBJECT_PATH)                                  \
   163    || (type ==  DBUS_TYPE_SIGNATURE))
   164 #endif
   165 #endif
   166 
   167 /* This was a macro.  On Solaris 2.11 it was said to compile for
   168    hours, when optimization is enabled.  So we have transferred it into
   169    a function.  */
   170 /* Determine the DBusType of a given Lisp symbol.  OBJECT must be one
   171    of the predefined D-Bus type symbols.  */
   172 static int
   173 xd_symbol_to_dbus_type (Lisp_Object object)
   174 {
   175   return
   176     (EQ (object, QCbyte) ? DBUS_TYPE_BYTE
   177      : EQ (object, QCboolean) ? DBUS_TYPE_BOOLEAN
   178      : EQ (object, QCint16) ? DBUS_TYPE_INT16
   179      : EQ (object, QCuint16) ? DBUS_TYPE_UINT16
   180      : EQ (object, QCint32) ? DBUS_TYPE_INT32
   181      : EQ (object, QCuint32) ? DBUS_TYPE_UINT32
   182      : EQ (object, QCint64) ? DBUS_TYPE_INT64
   183      : EQ (object, QCuint64) ? DBUS_TYPE_UINT64
   184      : EQ (object, QCdouble) ? DBUS_TYPE_DOUBLE
   185      : EQ (object, QCstring) ? DBUS_TYPE_STRING
   186      : EQ (object, QCobject_path) ? DBUS_TYPE_OBJECT_PATH
   187      : EQ (object, QCsignature) ? DBUS_TYPE_SIGNATURE
   188 #ifdef DBUS_TYPE_UNIX_FD
   189      : EQ (object, QCunix_fd) ? DBUS_TYPE_UNIX_FD
   190 #endif
   191      : EQ (object, QCarray) ? DBUS_TYPE_ARRAY
   192      : EQ (object, QCvariant) ? DBUS_TYPE_VARIANT
   193      : EQ (object, QCstruct) ? DBUS_TYPE_STRUCT
   194      : EQ (object, QCdict_entry) ? DBUS_TYPE_DICT_ENTRY
   195      : DBUS_TYPE_INVALID);
   196 }
   197 
   198 /* Determine the Lisp symbol of DBusType.  */
   199 static Lisp_Object
   200 xd_dbus_type_to_symbol (int type)
   201 {
   202   return
   203     (type == DBUS_TYPE_BYTE) ? QCbyte
   204     : (type == DBUS_TYPE_BOOLEAN) ? QCboolean
   205     : (type == DBUS_TYPE_INT16) ? QCint16
   206     : (type == DBUS_TYPE_UINT16) ? QCuint16
   207     : (type == DBUS_TYPE_INT32) ? QCint32
   208     : (type == DBUS_TYPE_UINT32) ? QCuint32
   209     : (type == DBUS_TYPE_INT64) ? QCint64
   210     : (type == DBUS_TYPE_UINT64) ? QCuint64
   211     : (type == DBUS_TYPE_DOUBLE) ? QCdouble
   212     : (type == DBUS_TYPE_STRING) ? QCstring
   213     : (type == DBUS_TYPE_OBJECT_PATH) ? QCobject_path
   214     : (type == DBUS_TYPE_SIGNATURE) ? QCsignature
   215 #ifdef DBUS_TYPE_UNIX_FD
   216     : (type == DBUS_TYPE_UNIX_FD) ? QCunix_fd
   217 #endif
   218     : (type == DBUS_TYPE_ARRAY) ? QCarray
   219     : (type == DBUS_TYPE_VARIANT) ? QCvariant
   220     : (type == DBUS_TYPE_STRUCT) ? QCstruct
   221     : (type ==  DBUS_TYPE_DICT_ENTRY) ? QCdict_entry
   222     : Qnil;
   223 }
   224 
   225 #define XD_KEYWORDP(object) !NILP (Fkeywordp (object))
   226 
   227 /* Check whether a Lisp symbol is a predefined D-Bus type symbol.  */
   228 #define XD_DBUS_TYPE_P(object)                                          \
   229   XD_KEYWORDP (object) &&                                               \
   230     ((xd_symbol_to_dbus_type (object) != DBUS_TYPE_INVALID))
   231 
   232 /* Determine the DBusType of a given Lisp OBJECT.  It is used to
   233    convert Lisp objects, being arguments of `dbus-call-method' or
   234    `dbus-send-signal', into corresponding C values appended as
   235    arguments to a D-Bus message.  */
   236 #define XD_OBJECT_TO_DBUS_TYPE(object)                                  \
   237   ((EQ (object, Qt) || NILP (object)) ? DBUS_TYPE_BOOLEAN               \
   238    : (FIXNATP (object)) ? DBUS_TYPE_UINT32                              \
   239    : (FIXNUMP (object)) ? DBUS_TYPE_INT32                               \
   240    : (FLOATP (object)) ? DBUS_TYPE_DOUBLE                               \
   241    : (STRINGP (object)) ? DBUS_TYPE_STRING                              \
   242    : (XD_DBUS_TYPE_P (object)) ? xd_symbol_to_dbus_type (object)        \
   243    : (CONSP (object))                                                   \
   244    ? ((XD_DBUS_TYPE_P (XCAR (object)))                                  \
   245       ? ((XD_BASIC_DBUS_TYPE (xd_symbol_to_dbus_type (XCAR (object))))  \
   246          ? DBUS_TYPE_ARRAY                                              \
   247          : xd_symbol_to_dbus_type (XCAR (object)))                      \
   248       : DBUS_TYPE_ARRAY)                                                \
   249    : DBUS_TYPE_INVALID)
   250 
   251 /* Return a list pointer which does not have a Lisp symbol as car.  */
   252 #define XD_NEXT_VALUE(object)                                           \
   253   ((XD_DBUS_TYPE_P (CAR_SAFE (object))) ? CDR_SAFE (object) : object)
   254 
   255 /* Transform the message type to its string representation for debug
   256    messages.  */
   257 #define XD_MESSAGE_TYPE_TO_STRING(mtype)                                \
   258   ((mtype == DBUS_MESSAGE_TYPE_INVALID)                                 \
   259   ? "DBUS_MESSAGE_TYPE_INVALID"                                         \
   260   : (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)                            \
   261   ? "DBUS_MESSAGE_TYPE_METHOD_CALL"                                     \
   262   : (mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)                          \
   263   ? "DBUS_MESSAGE_TYPE_METHOD_RETURN"                                   \
   264   : (mtype == DBUS_MESSAGE_TYPE_ERROR)                                  \
   265    ? "DBUS_MESSAGE_TYPE_ERROR"                                          \
   266    : "DBUS_MESSAGE_TYPE_SIGNAL")
   267 
   268 /* Transform the object to its string representation for debug
   269    messages.  */
   270 static char *
   271 XD_OBJECT_TO_STRING (Lisp_Object object)
   272 {
   273   AUTO_STRING (format, "%s");
   274   return SSDATA (CALLN (Fformat, format, object));
   275 }
   276 
   277 #define XD_DBUS_VALIDATE_BUS_ADDRESS(bus)                               \
   278   do {                                                                  \
   279     char const *session_bus_address = egetenv ("DBUS_SESSION_BUS_ADDRESS"); \
   280     if (STRINGP (bus))                                                  \
   281       {                                                                 \
   282         DBusAddressEntry **entries;                                     \
   283         int len;                                                        \
   284         DBusError derror;                                               \
   285         dbus_error_init (&derror);                                      \
   286         if (!dbus_parse_address (SSDATA (bus), &entries, &len, &derror)) \
   287           XD_ERROR (derror);                                            \
   288         /* Cleanup.  */                                                 \
   289         dbus_error_free (&derror);                                      \
   290         dbus_address_entries_free (entries);                            \
   291         /* Canonicalize session bus address.  */                        \
   292         if ((session_bus_address != NULL)                               \
   293             && (!NILP (Fstring_equal                                    \
   294                        (bus, build_string (session_bus_address)))))     \
   295           bus = QCsession;                                              \
   296       }                                                                 \
   297                                                                         \
   298     else                                                                \
   299       {                                                                 \
   300         CHECK_SYMBOL (bus);                                             \
   301         if (!(EQ (bus, QCsystem) || EQ (bus, QCsession)                 \
   302               || EQ (bus, QCsystem_private)                             \
   303               || EQ (bus, QCsession_private)))                          \
   304           XD_SIGNAL2 (build_string ("Wrong bus name"), bus);            \
   305         /* We do not want to have an autolaunch for the session bus.  */ \
   306         if ((EQ (bus, QCsession) || EQ (bus, QCsession_private))        \
   307             && session_bus_address == NULL)                             \
   308           XD_SIGNAL2 (build_string ("No connection to bus"), bus);      \
   309       }                                                                 \
   310   } while (0)
   311 
   312 #if (HAVE_DBUS_VALIDATE_BUS_NAME || HAVE_DBUS_VALIDATE_PATH             \
   313      || HAVE_DBUS_VALIDATE_INTERFACE || HAVE_DBUS_VALIDATE_MEMBER)
   314 #define XD_DBUS_VALIDATE_OBJECT(object, func)                           \
   315   do {                                                                  \
   316     if (!NILP (object))                                                 \
   317       {                                                                 \
   318         DBusError derror;                                               \
   319         CHECK_STRING (object);                                          \
   320         dbus_error_init (&derror);                                      \
   321         if (!func (SSDATA (object), &derror))                           \
   322           XD_ERROR (derror);                                            \
   323         /* Cleanup.  */                                                 \
   324         dbus_error_free (&derror);                                      \
   325       }                                                                 \
   326   } while (0)
   327 #endif
   328 
   329 #if HAVE_DBUS_VALIDATE_BUS_NAME
   330 #define XD_DBUS_VALIDATE_BUS_NAME(bus_name)                             \
   331   XD_DBUS_VALIDATE_OBJECT(bus_name, dbus_validate_bus_name);
   332 #else
   333 #define XD_DBUS_VALIDATE_BUS_NAME(bus_name)                             \
   334   if (!NILP (bus_name)) CHECK_STRING (bus_name);
   335 #endif
   336 
   337 #if HAVE_DBUS_VALIDATE_PATH
   338 #define XD_DBUS_VALIDATE_PATH(path)                                     \
   339   XD_DBUS_VALIDATE_OBJECT(path, dbus_validate_path);
   340 #else
   341 #define XD_DBUS_VALIDATE_PATH(path)                                     \
   342   if (!NILP (path)) CHECK_STRING (path);
   343 #endif
   344 
   345 #if HAVE_DBUS_VALIDATE_INTERFACE
   346 #define XD_DBUS_VALIDATE_INTERFACE(interface)                           \
   347   XD_DBUS_VALIDATE_OBJECT(interface, dbus_validate_interface);
   348 #else
   349 #define XD_DBUS_VALIDATE_INTERFACE(interface)                           \
   350   if (!NILP (interface)) CHECK_STRING (interface);
   351 #endif
   352 
   353 #if HAVE_DBUS_VALIDATE_MEMBER
   354 #define XD_DBUS_VALIDATE_MEMBER(member)                                 \
   355   XD_DBUS_VALIDATE_OBJECT(member, dbus_validate_member);
   356 #else
   357 #define XD_DBUS_VALIDATE_MEMBER(member)                                 \
   358   if (!NILP (member)) CHECK_STRING (member);
   359 #endif
   360 
   361 /* Append to SIGNATURE a copy of X, making sure SIGNATURE does
   362    not become too long.  */
   363 static void
   364 xd_signature_cat (char *signature, char const *x)
   365 {
   366   ptrdiff_t siglen = strlen (signature);
   367   ptrdiff_t xlen = strlen (x);
   368   if (DBUS_MAXIMUM_SIGNATURE_LENGTH - xlen <= siglen)
   369     string_overflow ();
   370   strcpy (signature + siglen, x);
   371 }
   372 
   373 /* Compute SIGNATURE of OBJECT.  It must have a form that it can be
   374    used in dbus_message_iter_open_container.  DTYPE is the DBusType
   375    the object is related to.  It is passed as argument, because it
   376    cannot be detected in basic type objects, when they are preceded by
   377    a type symbol.  PARENT_TYPE is the DBusType of a container this
   378    signature is embedded, or DBUS_TYPE_INVALID.  It is needed for the
   379    check that DBUS_TYPE_DICT_ENTRY occurs only as array element.  */
   380 static void
   381 xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object)
   382 {
   383   int subtype;
   384   Lisp_Object elt;
   385   char const *subsig;
   386   char x[DBUS_MAXIMUM_SIGNATURE_LENGTH];
   387 
   388   elt = object;
   389 
   390   switch (dtype)
   391     {
   392     case DBUS_TYPE_BYTE:
   393     case DBUS_TYPE_UINT16:
   394       CHECK_FIXNAT (object);
   395       sprintf (signature, "%c", dtype);
   396       break;
   397 
   398     case DBUS_TYPE_BOOLEAN:
   399       /* There must be an argument.  */
   400       if (EQ (QCboolean, object))
   401         wrong_type_argument (Qbooleanp, object);
   402       sprintf (signature, "%c", dtype);
   403       break;
   404 
   405     case DBUS_TYPE_INT16:
   406       CHECK_FIXNUM (object);
   407       sprintf (signature, "%c", dtype);
   408       break;
   409 
   410     case DBUS_TYPE_UINT32:
   411     case DBUS_TYPE_UINT64:
   412 #ifdef DBUS_TYPE_UNIX_FD
   413     case DBUS_TYPE_UNIX_FD:
   414 #endif
   415     case DBUS_TYPE_INT32:
   416     case DBUS_TYPE_INT64:
   417     case DBUS_TYPE_DOUBLE:
   418       CHECK_NUMBER (object);
   419       sprintf (signature, "%c", dtype);
   420       break;
   421 
   422     case DBUS_TYPE_STRING:
   423     case DBUS_TYPE_OBJECT_PATH:
   424     case DBUS_TYPE_SIGNATURE:
   425       /* We don't check the syntax of signature.  This will be done by
   426          libdbus.  */
   427       if (dtype == DBUS_TYPE_OBJECT_PATH)
   428         XD_DBUS_VALIDATE_PATH (object)
   429       else
   430         CHECK_STRING (object);
   431       sprintf (signature, "%c", dtype);
   432       break;
   433 
   434     case DBUS_TYPE_ARRAY:
   435       /* Check that all list elements have the same D-Bus type.  For
   436          complex element types, we just check the container type, not
   437          the whole element's signature.  */
   438       CHECK_CONS (object);
   439 
   440       /* Type symbol is optional.  */
   441       if (EQ (QCarray, XCAR (elt)))
   442         elt = XD_NEXT_VALUE (elt);
   443 
   444       /* If the array is empty, DBUS_TYPE_STRING is the default
   445          element type.  */
   446       if (NILP (elt))
   447         {
   448           subtype = DBUS_TYPE_STRING;
   449           subsig = DBUS_TYPE_STRING_AS_STRING;
   450         }
   451       else
   452         {
   453           subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
   454           xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
   455           subsig = x;
   456         }
   457 
   458       /* If the element type is DBUS_TYPE_SIGNATURE, and this is the
   459          only element, the value of this element is used as the
   460          array's element signature.  */
   461       if (subtype == DBUS_TYPE_SIGNATURE)
   462         {
   463           Lisp_Object elt1 = XD_NEXT_VALUE (elt);
   464           if (CONSP (elt1) && STRINGP (XCAR (elt1)) && NILP (XCDR (elt1)))
   465             {
   466               subsig = SSDATA (XCAR (elt1));
   467               elt = Qnil;
   468             }
   469         }
   470 
   471       while (!NILP (elt))
   472         {
   473           char x[DBUS_MAXIMUM_SIGNATURE_LENGTH];
   474           subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
   475           xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
   476           if (strcmp (subsig, x) != 0)
   477             wrong_type_argument (intern ("D-Bus"), CAR_SAFE (elt));
   478           elt = CDR_SAFE (XD_NEXT_VALUE (elt));
   479         }
   480 
   481       signature[0] = dtype;
   482       signature[1] = '\0';
   483       xd_signature_cat (signature, subsig);
   484       break;
   485 
   486     case DBUS_TYPE_VARIANT:
   487       /* Check that there is exactly one list element.  */
   488       CHECK_CONS (object);
   489 
   490       elt = XD_NEXT_VALUE (elt);
   491       CHECK_CONS (elt);
   492       subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
   493       xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
   494 
   495       if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
   496         wrong_type_argument (intern ("D-Bus"),
   497                              CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt))));
   498 
   499       sprintf (signature, "%c", dtype);
   500       break;
   501 
   502     case DBUS_TYPE_STRUCT:
   503       /* A struct list might contain any (but zero) number of elements
   504          with different types.  No further check needed.  */
   505       CHECK_CONS (object);
   506 
   507       elt = XD_NEXT_VALUE (elt);
   508       CHECK_CONS (elt);
   509 
   510       /* Compose the signature from the elements.  It is enclosed by
   511          parentheses.  */
   512       sprintf (signature, "%c", DBUS_STRUCT_BEGIN_CHAR );
   513       while (!NILP (elt))
   514         {
   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);
   518           elt = CDR_SAFE (XD_NEXT_VALUE (elt));
   519         }
   520       xd_signature_cat (signature, DBUS_STRUCT_END_CHAR_AS_STRING);
   521       break;
   522 
   523     case DBUS_TYPE_DICT_ENTRY:
   524       /* Check that there are exactly two list elements, and the first
   525          one is of basic type.  The dictionary entry itself must be an
   526          element of an array.  */
   527       CHECK_CONS (object);
   528 
   529       /* Check the parent object type.  */
   530       if (parent_type != DBUS_TYPE_ARRAY)
   531         wrong_type_argument (intern ("D-Bus"), object);
   532 
   533       /* Compose the signature from the elements.  It is enclosed by
   534          curly braces.  */
   535       sprintf (signature, "%c", DBUS_DICT_ENTRY_BEGIN_CHAR);
   536 
   537       /* First element.  */
   538       elt = XD_NEXT_VALUE (elt);
   539       CHECK_CONS (elt);
   540       subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
   541       xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
   542       xd_signature_cat (signature, x);
   543 
   544       if (!XD_BASIC_DBUS_TYPE (subtype))
   545         wrong_type_argument (intern ("D-Bus"), CAR_SAFE (XD_NEXT_VALUE (elt)));
   546 
   547       /* Second element.  */
   548       elt = CDR_SAFE (XD_NEXT_VALUE (elt));
   549       CHECK_CONS (elt);
   550       subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
   551       xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
   552       xd_signature_cat (signature, x);
   553 
   554       if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
   555         wrong_type_argument (intern ("D-Bus"),
   556                              CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt))));
   557 
   558       /* Closing signature.  */
   559       xd_signature_cat (signature, DBUS_DICT_ENTRY_END_CHAR_AS_STRING);
   560       break;
   561 
   562     default:
   563       wrong_type_argument (intern ("D-Bus"), object);
   564     }
   565 
   566   XD_DEBUG_MESSAGE ("%s", signature);
   567 }
   568 
   569 /* Convert X to a signed integer with bounds LO and HI.  */
   570 static intmax_t
   571 xd_extract_signed (Lisp_Object x, intmax_t lo, intmax_t hi)
   572 {
   573   CHECK_NUMBER (x);
   574   if (INTEGERP (x))
   575     {
   576       intmax_t i;
   577       if (integer_to_intmax (x, &i) && lo <= i && i <= hi)
   578         return i;
   579     }
   580   else
   581     {
   582       double d = XFLOAT_DATA (x);
   583       if (lo <= d && d < 1.0 + hi)
   584         {
   585           intmax_t n = d;
   586           if (n == d)
   587             return n;
   588         }
   589     }
   590 
   591   if (xd_in_read_queued_messages)
   592     Fthrow (Qdbus_error, Qnil);
   593   else
   594     args_out_of_range_3 (x, INT_TO_INTEGER (lo), INT_TO_INTEGER (hi));
   595 }
   596 
   597 /* Convert X to an unsigned integer with bounds 0 and HI.  */
   598 static uintmax_t
   599 xd_extract_unsigned (Lisp_Object x, uintmax_t hi)
   600 {
   601   CHECK_NUMBER (x);
   602   if (INTEGERP (x))
   603     {
   604       uintmax_t i;
   605       if (integer_to_uintmax (x, &i) && i <= hi)
   606         return i;
   607     }
   608   else
   609     {
   610       double d = XFLOAT_DATA (x);
   611       if (0 <= d && d < 1.0 + hi)
   612         {
   613           uintmax_t n = d;
   614           if (n == d)
   615             return n;
   616         }
   617     }
   618 
   619   if (xd_in_read_queued_messages)
   620     Fthrow (Qdbus_error, Qnil);
   621   else
   622     args_out_of_range_3 (x, make_fixnum (0), INT_TO_INTEGER (hi));
   623 }
   624 
   625 /* Append C value, extracted from Lisp OBJECT, to iteration ITER.
   626    DTYPE must be a valid DBusType.  It is used to convert Lisp
   627    objects, being arguments of `dbus-call-method' or
   628    `dbus-send-signal', into corresponding C values appended as
   629    arguments to a D-Bus message.  */
   630 static void
   631 xd_append_arg (int dtype, Lisp_Object object, DBusMessageIter *iter)
   632 {
   633   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
   634   DBusMessageIter subiter;
   635 
   636   if (XD_BASIC_DBUS_TYPE (dtype))
   637     switch (dtype)
   638       {
   639       case DBUS_TYPE_BYTE:
   640         CHECK_FIXNAT (object);
   641         {
   642           unsigned char val = XFIXNAT (object) & 0xFF;
   643           XD_DEBUG_MESSAGE ("%c %u", dtype, val);
   644           if (!dbus_message_iter_append_basic (iter, dtype, &val))
   645             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
   646           return;
   647         }
   648 
   649       case DBUS_TYPE_BOOLEAN:
   650         /* There must be an argument.  */
   651         if (EQ (QCboolean, object))
   652           wrong_type_argument (Qbooleanp, object);
   653         {
   654           dbus_bool_t val = (NILP (object)) ? FALSE : TRUE;
   655           XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true");
   656           if (!dbus_message_iter_append_basic (iter, dtype, &val))
   657             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
   658           return;
   659         }
   660 
   661       case DBUS_TYPE_INT16:
   662         {
   663           dbus_int16_t val =
   664             xd_extract_signed (object,
   665                                TYPE_MINIMUM (dbus_int16_t),
   666                                TYPE_MAXIMUM (dbus_int16_t));
   667           int pval = val;
   668           XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
   669           if (!dbus_message_iter_append_basic (iter, dtype, &val))
   670             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
   671           return;
   672         }
   673 
   674       case DBUS_TYPE_UINT16:
   675         {
   676           dbus_uint16_t val =
   677             xd_extract_unsigned (object,
   678                                  TYPE_MAXIMUM (dbus_uint16_t));
   679           unsigned int pval = val;
   680           XD_DEBUG_MESSAGE ("%c %u", dtype, pval);
   681           if (!dbus_message_iter_append_basic (iter, dtype, &val))
   682             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
   683           return;
   684         }
   685 
   686       case DBUS_TYPE_INT32:
   687         {
   688           dbus_int32_t val =
   689             xd_extract_signed (object,
   690                                TYPE_MINIMUM (dbus_int32_t),
   691                                TYPE_MAXIMUM (dbus_int32_t));
   692           int pval = val;
   693           XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
   694           if (!dbus_message_iter_append_basic (iter, dtype, &val))
   695             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
   696           return;
   697         }
   698 
   699       case DBUS_TYPE_UINT32:
   700 #ifdef DBUS_TYPE_UNIX_FD
   701       case DBUS_TYPE_UNIX_FD:
   702 #endif
   703         {
   704           dbus_uint32_t val =
   705             xd_extract_unsigned (object,
   706                                  TYPE_MAXIMUM (dbus_uint32_t));
   707           unsigned int pval = val;
   708           XD_DEBUG_MESSAGE ("%c %u", dtype, pval);
   709           if (!dbus_message_iter_append_basic (iter, dtype, &val))
   710             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
   711           return;
   712         }
   713 
   714       case DBUS_TYPE_INT64:
   715         {
   716           dbus_int64_t val =
   717             xd_extract_signed (object,
   718                                TYPE_MINIMUM (dbus_int64_t),
   719                                TYPE_MAXIMUM (dbus_int64_t));
   720           intmax_t pval = val;
   721           XD_DEBUG_MESSAGE ("%c %"PRIdMAX, dtype, pval);
   722           if (!dbus_message_iter_append_basic (iter, dtype, &val))
   723             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
   724           return;
   725         }
   726 
   727       case DBUS_TYPE_UINT64:
   728         {
   729           dbus_uint64_t val =
   730             xd_extract_unsigned (object,
   731                                  TYPE_MAXIMUM (dbus_uint64_t));
   732           uintmax_t pval = val;
   733           XD_DEBUG_MESSAGE ("%c %"PRIuMAX, dtype, pval);
   734           if (!dbus_message_iter_append_basic (iter, dtype, &val))
   735             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
   736           return;
   737         }
   738 
   739       case DBUS_TYPE_DOUBLE:
   740         {
   741           double val = extract_float (object);
   742           XD_DEBUG_MESSAGE ("%c %f", dtype, val);
   743           if (!dbus_message_iter_append_basic (iter, dtype, &val))
   744             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
   745           return;
   746         }
   747 
   748       case DBUS_TYPE_STRING:
   749       case DBUS_TYPE_OBJECT_PATH:
   750       case DBUS_TYPE_SIGNATURE:
   751         /* We don't check the syntax of signature.  This will be done
   752            by libdbus.  */
   753         if (dtype == DBUS_TYPE_OBJECT_PATH)
   754           XD_DBUS_VALIDATE_PATH (object)
   755         else
   756           CHECK_STRING (object);
   757         {
   758           /* We need to send a valid UTF-8 string.  We could encode `object'
   759              but by not encoding it, we guarantee it's valid utf-8, even if
   760              it contains eight-bit-bytes.  Of course, you can still send
   761              manually-crafted junk by passing a unibyte string.  */
   762           char *val = SSDATA (object);
   763           XD_DEBUG_MESSAGE ("%c %s", dtype, val);
   764           if (!dbus_message_iter_append_basic (iter, dtype, &val))
   765             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
   766           return;
   767         }
   768       }
   769 
   770   else /* Compound types.  */
   771     {
   772 
   773       /* All compound types except array have a type symbol.  For
   774          array, it is optional.  Skip it.  */
   775       if (!XD_BASIC_DBUS_TYPE (XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object))))
   776         object = XD_NEXT_VALUE (object);
   777 
   778       /* Open new subiteration.  */
   779       switch (dtype)
   780         {
   781         case DBUS_TYPE_ARRAY:
   782           /* An array has only elements of the same type.  So it is
   783              sufficient to check the first element's signature
   784              only.  */
   785 
   786           if (NILP (object))
   787             /* If the array is empty, DBUS_TYPE_STRING is the default
   788                element type.  */
   789             strcpy (signature, DBUS_TYPE_STRING_AS_STRING);
   790 
   791           else
   792             {
   793               /* If the element type is DBUS_TYPE_SIGNATURE, and this is
   794                  the only element, the value of this element is used as
   795                  the array's element signature.  */
   796               if (CONSP (object) && (XD_OBJECT_TO_DBUS_TYPE (XCAR (object))
   797                                      == DBUS_TYPE_SIGNATURE))
   798                 {
   799                   Lisp_Object val = XD_NEXT_VALUE (object);
   800                   if (CONSP (val) && STRINGP (XCAR (val)) && NILP (XCDR (val))
   801                       && SBYTES (XCAR (val)) < DBUS_MAXIMUM_SIGNATURE_LENGTH)
   802                     {
   803                       lispstpcpy (signature, XCAR (val));
   804                       object = Qnil;
   805                     }
   806                 }
   807 
   808               if (!NILP (object))
   809                 xd_signature (signature,
   810                               XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object)),
   811                               dtype, CAR_SAFE (XD_NEXT_VALUE (object)));
   812             }
   813 
   814           XD_DEBUG_MESSAGE ("%c %s %s", dtype, signature,
   815                             XD_OBJECT_TO_STRING (object));
   816           if (!dbus_message_iter_open_container (iter, dtype,
   817                                                  signature, &subiter))
   818             XD_SIGNAL3 (build_string ("Cannot open container"),
   819                         make_fixnum (dtype), build_string (signature));
   820           break;
   821 
   822         case DBUS_TYPE_VARIANT:
   823           /* A variant has just one element.  */
   824           xd_signature (signature, XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object)),
   825                         dtype, CAR_SAFE (XD_NEXT_VALUE (object)));
   826 
   827           XD_DEBUG_MESSAGE ("%c %s %s", dtype, signature,
   828                             XD_OBJECT_TO_STRING (object));
   829           if (!dbus_message_iter_open_container (iter, dtype,
   830                                                  signature, &subiter))
   831             XD_SIGNAL3 (build_string ("Cannot open container"),
   832                         make_fixnum (dtype), build_string (signature));
   833           break;
   834 
   835         case DBUS_TYPE_STRUCT:
   836         case DBUS_TYPE_DICT_ENTRY:
   837           /* These containers do not require a signature.  */
   838           XD_DEBUG_MESSAGE ("%c %s", dtype, XD_OBJECT_TO_STRING (object));
   839           if (!dbus_message_iter_open_container (iter, dtype, NULL, &subiter))
   840             XD_SIGNAL2 (build_string ("Cannot open container"),
   841                         make_fixnum (dtype));
   842           break;
   843         }
   844 
   845       /* Loop over list elements.  */
   846       while (!NILP (object))
   847         {
   848           dtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object));
   849           object = XD_NEXT_VALUE (object);
   850 
   851           xd_append_arg (dtype, CAR_SAFE (object), &subiter);
   852 
   853           object = CDR_SAFE (object);
   854         }
   855 
   856       /* Close the subiteration.  */
   857       if (!dbus_message_iter_close_container (iter, &subiter))
   858         XD_SIGNAL2 (build_string ("Cannot close container"),
   859                     make_fixnum (dtype));
   860     }
   861 }
   862 
   863 /* Retrieve C value from a DBusMessageIter structure ITER, and return
   864    a converted Lisp object.  The type DTYPE of the argument of the
   865    D-Bus message must be a valid DBusType.  Compound D-Bus types
   866    result always in a Lisp list.  */
   867 static Lisp_Object
   868 xd_retrieve_arg (int dtype, DBusMessageIter *iter)
   869 {
   870 
   871   switch (dtype)
   872     {
   873     case DBUS_TYPE_BYTE:
   874       {
   875         unsigned int val;
   876         dbus_message_iter_get_basic (iter, &val);
   877         val = val & 0xFF;
   878         XD_DEBUG_MESSAGE ("%c %u", dtype, val);
   879         return list2 (xd_dbus_type_to_symbol (dtype), make_fixnum (val));
   880       }
   881 
   882     case DBUS_TYPE_BOOLEAN:
   883       {
   884         dbus_bool_t val;
   885         dbus_message_iter_get_basic (iter, &val);
   886         XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true");
   887         return list2 (xd_dbus_type_to_symbol (dtype),
   888                       (val == FALSE) ? Qnil : Qt);
   889       }
   890 
   891     case DBUS_TYPE_INT16:
   892       {
   893         dbus_int16_t val;
   894         int pval;
   895         dbus_message_iter_get_basic (iter, &val);
   896         pval = val;
   897         XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
   898         return list2 (xd_dbus_type_to_symbol (dtype), make_fixnum (val));
   899       }
   900 
   901     case DBUS_TYPE_UINT16:
   902       {
   903         dbus_uint16_t val;
   904         int pval;
   905         dbus_message_iter_get_basic (iter, &val);
   906         pval = val;
   907         XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
   908         return list2 (xd_dbus_type_to_symbol (dtype), make_fixnum (val));
   909       }
   910 
   911     case DBUS_TYPE_INT32:
   912       {
   913         dbus_int32_t val;
   914         int pval;
   915         dbus_message_iter_get_basic (iter, &val);
   916         pval = val;
   917         XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
   918         return list2 (xd_dbus_type_to_symbol (dtype), INT_TO_INTEGER (val));
   919       }
   920 
   921     case DBUS_TYPE_UINT32:
   922 #ifdef DBUS_TYPE_UNIX_FD
   923     case DBUS_TYPE_UNIX_FD:
   924 #endif
   925       {
   926         dbus_uint32_t val;
   927         unsigned int pval;
   928         dbus_message_iter_get_basic (iter, &val);
   929         pval = val;
   930         XD_DEBUG_MESSAGE ("%c %u", dtype, pval);
   931         return list2 (xd_dbus_type_to_symbol (dtype), INT_TO_INTEGER (val));
   932       }
   933 
   934     case DBUS_TYPE_INT64:
   935       {
   936         dbus_int64_t val;
   937         dbus_message_iter_get_basic (iter, &val);
   938         intmax_t pval = val;
   939         XD_DEBUG_MESSAGE ("%c %"PRIdMAX, dtype, pval);
   940         return list2 (xd_dbus_type_to_symbol (dtype), INT_TO_INTEGER (val));
   941       }
   942 
   943     case DBUS_TYPE_UINT64:
   944       {
   945         dbus_uint64_t val;
   946         dbus_message_iter_get_basic (iter, &val);
   947         uintmax_t pval = val;
   948         XD_DEBUG_MESSAGE ("%c %"PRIuMAX, dtype, pval);
   949         return list2 (xd_dbus_type_to_symbol (dtype), INT_TO_INTEGER (val));
   950       }
   951 
   952     case DBUS_TYPE_DOUBLE:
   953       {
   954         double val;
   955         dbus_message_iter_get_basic (iter, &val);
   956         XD_DEBUG_MESSAGE ("%c %f", dtype, val);
   957         return list2 (xd_dbus_type_to_symbol (dtype), make_float (val));
   958       }
   959 
   960     case DBUS_TYPE_STRING:
   961     case DBUS_TYPE_OBJECT_PATH:
   962     case DBUS_TYPE_SIGNATURE:
   963       {
   964         char *val;
   965         dbus_message_iter_get_basic (iter, &val);
   966         XD_DEBUG_MESSAGE ("%c %s", dtype, val);
   967         return list2 (xd_dbus_type_to_symbol (dtype), build_string (val));
   968       }
   969 
   970     case DBUS_TYPE_ARRAY:
   971     case DBUS_TYPE_VARIANT:
   972     case DBUS_TYPE_STRUCT:
   973     case DBUS_TYPE_DICT_ENTRY:
   974       {
   975         Lisp_Object result;
   976         DBusMessageIter subiter;
   977         int subtype;
   978         result = Qnil;
   979         dbus_message_iter_recurse (iter, &subiter);
   980         while ((subtype = dbus_message_iter_get_arg_type (&subiter))
   981                != DBUS_TYPE_INVALID)
   982           {
   983             result = Fcons (xd_retrieve_arg (subtype, &subiter), result);
   984             dbus_message_iter_next (&subiter);
   985           }
   986         XD_DEBUG_MESSAGE ("%c %s", dtype, XD_OBJECT_TO_STRING (result));
   987         return Fcons (xd_dbus_type_to_symbol (dtype), Fnreverse (result));
   988       }
   989 
   990     default:
   991       XD_DEBUG_MESSAGE ("DBusType '%c' not supported", dtype);
   992       return Qnil;
   993     }
   994 }
   995 
   996 /* Return the number of references of the shared CONNECTION.  */
   997 static ptrdiff_t
   998 xd_get_connection_references (DBusConnection *connection)
   999 {
  1000   ptrdiff_t *refcount;
  1001 
  1002   /* We cannot access the DBusConnection structure, it is not public.
  1003      But we know, that the reference counter is the first field in
  1004      that structure.  */
  1005   refcount = (void *) &connection;
  1006   refcount =  (void *) *refcount;
  1007   return *refcount;
  1008 }
  1009 
  1010 /* Convert a Lisp D-Bus object to a pointer.  */
  1011 static DBusConnection *
  1012 xd_lisp_dbus_to_dbus (Lisp_Object bus)
  1013 {
  1014   return xmint_pointer (bus);
  1015 }
  1016 
  1017 /* Return D-Bus connection address.
  1018    BUS is either a Lisp symbol, :system, :session, :system-private or
  1019    :session-private, or a string denoting the bus address.  */
  1020 static DBusConnection *
  1021 xd_get_connection_address (Lisp_Object bus)
  1022 {
  1023   DBusConnection *connection;
  1024   Lisp_Object val;
  1025 
  1026   val = CDR_SAFE (Fassoc (bus, xd_registered_buses, Qnil));
  1027   if (NILP (val))
  1028     XD_SIGNAL2 (build_string ("No connection to bus"), bus);
  1029   else
  1030     connection = xd_lisp_dbus_to_dbus (val);
  1031 
  1032   if (!dbus_connection_get_is_connected (connection))
  1033     XD_SIGNAL2 (build_string ("No connection to bus"), bus);
  1034 
  1035   return connection;
  1036 }
  1037 
  1038 /* Return the file descriptor for WATCH, -1 if not found.  */
  1039 static int
  1040 xd_find_watch_fd (DBusWatch *watch)
  1041 {
  1042 #if HAVE_DBUS_WATCH_GET_UNIX_FD
  1043   /* TODO: Reverse these on w32, which prefers the opposite.  */
  1044   int fd = dbus_watch_get_unix_fd (watch);
  1045   if (fd == -1)
  1046     fd = dbus_watch_get_socket (watch);
  1047 #else
  1048   int fd = dbus_watch_get_fd (watch);
  1049 #endif
  1050   return fd;
  1051 }
  1052 
  1053 /* Prototype.  */
  1054 static void xd_read_queued_messages (int fd, void *data);
  1055 
  1056 /* Start monitoring WATCH for possible I/O.  */
  1057 static dbus_bool_t
  1058 xd_add_watch (DBusWatch *watch, void *data)
  1059 {
  1060   unsigned int flags = dbus_watch_get_flags (watch);
  1061   int fd = xd_find_watch_fd (watch);
  1062 
  1063   XD_DEBUG_MESSAGE ("fd %d, write %u, enabled %u",
  1064                     fd, flags & DBUS_WATCH_WRITABLE,
  1065                     dbus_watch_get_enabled (watch));
  1066 
  1067   if (fd == -1)
  1068     return FALSE;
  1069 
  1070   if (dbus_watch_get_enabled (watch))
  1071     {
  1072       if (flags & DBUS_WATCH_WRITABLE)
  1073         add_write_fd (fd, xd_read_queued_messages, data);
  1074       if (flags & DBUS_WATCH_READABLE)
  1075         add_read_fd (fd, xd_read_queued_messages, data);
  1076     }
  1077   return TRUE;
  1078 }
  1079 
  1080 /* Stop monitoring WATCH for possible I/O.
  1081    DATA is the used bus, either a string or QCsystem, QCsession,
  1082    QCsystem_private or QCsession_private.  */
  1083 static void
  1084 xd_remove_watch (DBusWatch *watch, void *data)
  1085 {
  1086   unsigned int flags = dbus_watch_get_flags (watch);
  1087   int fd = xd_find_watch_fd (watch);
  1088 
  1089   XD_DEBUG_MESSAGE ("fd %d", fd);
  1090 
  1091   if (fd == -1)
  1092     return;
  1093 
  1094   /* Unset session environment.  */
  1095 #if 0
  1096   /* This is buggy, since unsetenv is not thread-safe.  */
  1097   if (XSYMBOL (QCsession) == data) || (XSYMBOL (QCsession_private) == data)
  1098     {
  1099       XD_DEBUG_MESSAGE ("unsetenv DBUS_SESSION_BUS_ADDRESS");
  1100       unsetenv ("DBUS_SESSION_BUS_ADDRESS");
  1101     }
  1102 #endif
  1103 
  1104   if (flags & DBUS_WATCH_WRITABLE)
  1105     delete_write_fd (fd);
  1106   if (flags & DBUS_WATCH_READABLE)
  1107     delete_read_fd (fd);
  1108 }
  1109 
  1110 /* Toggle monitoring WATCH for possible I/O.  */
  1111 static void
  1112 xd_toggle_watch (DBusWatch *watch, void *data)
  1113 {
  1114   if (dbus_watch_get_enabled (watch))
  1115     xd_add_watch (watch, data);
  1116   else
  1117     xd_remove_watch (watch, data);
  1118 }
  1119 
  1120 /* Close connection to D-Bus BUS.  */
  1121 static void
  1122 xd_close_bus (Lisp_Object bus)
  1123 {
  1124   DBusConnection *connection;
  1125   Lisp_Object val;
  1126   Lisp_Object busobj;
  1127 
  1128   /* Check whether we are connected.  */
  1129   val = Fassoc (bus, xd_registered_buses, Qnil);
  1130   if (NILP (val))
  1131     return;
  1132 
  1133   busobj = CDR_SAFE (val);
  1134   if (NILP (busobj)) {
  1135     xd_registered_buses = Fdelete (val, xd_registered_buses);
  1136     return;
  1137   }
  1138 
  1139   /* Retrieve bus address.  */
  1140   connection = xd_lisp_dbus_to_dbus (busobj);
  1141 
  1142   if (xd_get_connection_references (connection) == 1)
  1143     {
  1144       /* Close connection, if there isn't another shared application.  */
  1145       XD_DEBUG_MESSAGE ("Close connection to bus %s",
  1146                         XD_OBJECT_TO_STRING (bus));
  1147       dbus_connection_close (connection);
  1148 
  1149       xd_registered_buses = Fdelete (val, xd_registered_buses);
  1150     }
  1151 
  1152   else
  1153     /* Decrement reference count.  */
  1154     dbus_connection_unref (connection);
  1155 
  1156   /* Return.  */
  1157   return;
  1158 }
  1159 
  1160 DEFUN ("dbus--init-bus", Fdbus__init_bus, Sdbus__init_bus, 1, 2, 0,
  1161        doc: /* Establish the connection to D-Bus BUS.
  1162 
  1163 This function is dbus internal.  You almost certainly want to use
  1164 `dbus-init-bus'.
  1165 
  1166 BUS can be either the symbol `:system' or the symbol `:session', or it
  1167 can be a string denoting the address of the corresponding bus.  For
  1168 the system and session buses, this function is called when loading
  1169 `dbus.el', there is no need to call it again.
  1170 
  1171 A special case is BUS being the symbol `:system-private' or
  1172 `:session-private'.  These symbols still denote the system or session
  1173 bus, but using a private connection.  They should not be used outside
  1174 dbus.el.
  1175 
  1176 The function returns a number, which counts the connections this Emacs
  1177 session has established to the BUS under the same unique name (see
  1178 `dbus-get-unique-name').  It depends on the libraries Emacs is linked
  1179 with, and on the environment Emacs is running.  For example, if Emacs
  1180 is linked with the gtk toolkit, and it runs in a GTK-aware environment
  1181 like Gnome, another connection might already be established.
  1182 
  1183 When PRIVATE is non-nil, a new connection is established instead of
  1184 reusing an existing one.  It results in a new unique name at the bus.
  1185 This can be used, if it is necessary to distinguish from another
  1186 connection used in the same Emacs process, like the one established by
  1187 GTK+.  It should be used with care for at least the `:system' and
  1188 `:session' buses, because other Emacs Lisp packages might already use
  1189 this connection to those buses.  */)
  1190   (Lisp_Object bus, Lisp_Object private)
  1191 {
  1192   DBusConnection *connection;
  1193   DBusError derror;
  1194   Lisp_Object val;
  1195   ptrdiff_t refcount;
  1196 
  1197   /* Check parameter.  */
  1198   if (!NILP (private))
  1199     bus = EQ (bus, QCsystem)
  1200       ? QCsystem_private
  1201       : EQ (bus, QCsession) ? QCsession_private : bus;
  1202   XD_DBUS_VALIDATE_BUS_ADDRESS (bus);
  1203 
  1204   /* Close bus if it is already open.  */
  1205   xd_close_bus (bus);
  1206 
  1207   /* Check, whether we are still connected.  */
  1208   val = Fassoc (bus, xd_registered_buses, Qnil);
  1209   if (!NILP (val))
  1210     {
  1211       connection = xd_get_connection_address (bus);
  1212       dbus_connection_ref (connection);
  1213     }
  1214 
  1215   else
  1216     {
  1217       /* Initialize.  */
  1218       dbus_error_init (&derror);
  1219 
  1220       /* Open the connection.  */
  1221       if (STRINGP (bus))
  1222         if (NILP (private))
  1223           connection = dbus_connection_open (SSDATA (bus), &derror);
  1224         else
  1225           connection = dbus_connection_open_private (SSDATA (bus), &derror);
  1226 
  1227       else
  1228         {
  1229           DBusBusType bustype
  1230             = EQ (bus, QCsystem) || EQ (bus, QCsystem_private)
  1231             ? DBUS_BUS_SYSTEM : DBUS_BUS_SESSION;
  1232           if (NILP (private))
  1233             connection = dbus_bus_get (bustype, &derror);
  1234           else
  1235             connection = dbus_bus_get_private (bustype, &derror);
  1236         }
  1237 
  1238       if (dbus_error_is_set (&derror))
  1239         XD_ERROR (derror);
  1240 
  1241       if (connection == NULL)
  1242         XD_SIGNAL2 (build_string ("No connection to bus"), bus);
  1243 
  1244       /* If it is not the system or session bus, we must register
  1245          ourselves.  Otherwise, we have called dbus_bus_get{_private},
  1246          which has configured us to exit if the connection closes - we
  1247          undo this setting.  */
  1248       if (STRINGP (bus))
  1249         dbus_bus_register (connection, &derror);
  1250       else
  1251         dbus_connection_set_exit_on_disconnect (connection, FALSE);
  1252 
  1253       if (dbus_error_is_set (&derror))
  1254         XD_ERROR (derror);
  1255 
  1256       /* Add the watch functions.  We pass also the bus as data, in
  1257          order to distinguish between the buses in xd_remove_watch.  */
  1258       if (!dbus_connection_set_watch_functions (connection,
  1259                                                 xd_add_watch,
  1260                                                 xd_remove_watch,
  1261                                                 xd_toggle_watch,
  1262                                                 XD_KEYWORDP (bus)
  1263                                                 ? (void *) XSYMBOL (bus)
  1264                                                 : (void *) XSTRING (bus),
  1265                                                 NULL))
  1266         XD_SIGNAL1 (build_string ("Cannot add watch functions"));
  1267 
  1268       /* Add bus to list of registered buses.  */
  1269       val = make_mint_ptr (connection);
  1270       xd_registered_buses = Fcons (Fcons (bus, val), xd_registered_buses);
  1271 
  1272       /* Cleanup.  */
  1273       dbus_error_free (&derror);
  1274     }
  1275 
  1276   XD_DEBUG_MESSAGE ("Registered buses: %s",
  1277                     XD_OBJECT_TO_STRING (xd_registered_buses));
  1278 
  1279   /* Return reference counter.  */
  1280   refcount = xd_get_connection_references (connection);
  1281   XD_DEBUG_MESSAGE ("Bus %s, Reference counter %"pD"d",
  1282                     XD_OBJECT_TO_STRING (bus), refcount);
  1283   return make_fixnum (refcount);
  1284 }
  1285 
  1286 DEFUN ("dbus-get-unique-name", Fdbus_get_unique_name, Sdbus_get_unique_name,
  1287        1, 1, 0,
  1288        doc: /* Return the unique name of Emacs registered at D-Bus BUS.  */)
  1289   (Lisp_Object bus)
  1290 {
  1291   DBusConnection *connection;
  1292   const char *name;
  1293 
  1294   /* Check parameter.  */
  1295   XD_DBUS_VALIDATE_BUS_ADDRESS (bus);
  1296 
  1297   /* Retrieve bus address.  */
  1298   connection = xd_get_connection_address (bus);
  1299 
  1300   /* Request the name.  */
  1301   name = dbus_bus_get_unique_name (connection);
  1302   if (name == NULL)
  1303     XD_SIGNAL1 (build_string ("No unique name available"));
  1304 
  1305   /* Return.  */
  1306   return build_string (name);
  1307 }
  1308 
  1309 DEFUN ("dbus-message-internal", Fdbus_message_internal, Sdbus_message_internal,
  1310        4, MANY, 0,
  1311        doc: /* Send a D-Bus message.
  1312 This is an internal function, it shall not be used outside dbus.el.
  1313 
  1314 The following usages are expected:
  1315 
  1316 `dbus-call-method', `dbus-call-method-asynchronously':
  1317   (dbus-message-internal
  1318     dbus-message-type-method-call BUS SERVICE PATH INTERFACE METHOD HANDLER
  1319     &optional :timeout TIMEOUT &rest ARGS)
  1320 
  1321 `dbus-send-signal':
  1322   (dbus-message-internal
  1323     dbus-message-type-signal BUS SERVICE PATH INTERFACE SIGNAL &rest ARGS)
  1324 
  1325 `dbus-method-return-internal':
  1326   (dbus-message-internal
  1327     dbus-message-type-method-return BUS SERVICE SERIAL &rest ARGS)
  1328 
  1329 `dbus-method-error-internal':
  1330   (dbus-message-internal
  1331     dbus-message-type-error BUS SERVICE SERIAL ERROR-NAME &rest ARGS)
  1332 
  1333 `dbus-check-arguments': (does not send a message)
  1334   (dbus-message-internal
  1335     dbus-message-type-invalid BUS SERVICE &rest ARGS)
  1336 
  1337 usage: (dbus-message-internal &rest REST)  */)
  1338   (ptrdiff_t nargs, Lisp_Object *args)
  1339 {
  1340   Lisp_Object message_type, bus, service, handler;
  1341   Lisp_Object path = Qnil;
  1342   Lisp_Object interface = Qnil;
  1343   Lisp_Object member = Qnil;
  1344   Lisp_Object error_name = Qnil;
  1345   Lisp_Object result;
  1346   DBusConnection *connection;
  1347   DBusMessage *dmessage;
  1348   DBusMessageIter iter;
  1349   int dtype;
  1350   int mtype;
  1351   dbus_uint32_t serial = 0;
  1352   unsigned int ui_serial;
  1353   int timeout = -1;
  1354   ptrdiff_t count, count0;
  1355   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
  1356 
  1357   /* Initialize parameters.  */
  1358   message_type = args[0];
  1359   bus = args[1];
  1360   service = args[2];
  1361   handler = Qnil;
  1362 
  1363   CHECK_FIXNAT (message_type);
  1364   if (! (DBUS_MESSAGE_TYPE_INVALID <= XFIXNAT (message_type)
  1365          && XFIXNAT (message_type) < DBUS_NUM_MESSAGE_TYPES))
  1366     XD_SIGNAL2 (build_string ("Invalid message type"), message_type);
  1367   mtype = XFIXNAT (message_type);
  1368 
  1369   if ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
  1370       || (mtype == DBUS_MESSAGE_TYPE_SIGNAL))
  1371     {
  1372       path = args[3];
  1373       interface = args[4];
  1374       member = args[5];
  1375       if (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
  1376         handler = args[6];
  1377       count = (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL) ? 7 : 6;
  1378     }
  1379   else if ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
  1380            || (mtype == DBUS_MESSAGE_TYPE_ERROR))
  1381     {
  1382       serial = xd_extract_unsigned (args[3], TYPE_MAXIMUM (dbus_uint32_t));
  1383       if (mtype == DBUS_MESSAGE_TYPE_ERROR)
  1384         error_name = args[4];
  1385       count = (mtype == DBUS_MESSAGE_TYPE_ERROR) ? 5 : 4;
  1386     }
  1387   else /* DBUS_MESSAGE_TYPE_INVALID  */
  1388     count = 3;
  1389 
  1390   /* Check parameters.  */
  1391   XD_DBUS_VALIDATE_BUS_ADDRESS (bus);
  1392   XD_DBUS_VALIDATE_BUS_NAME (service);
  1393   if (nargs < count)
  1394     xsignal2 (Qwrong_number_of_arguments,
  1395               Qdbus_message_internal,
  1396               make_fixnum (nargs));
  1397 
  1398   if ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
  1399       || (mtype == DBUS_MESSAGE_TYPE_SIGNAL))
  1400     {
  1401       XD_DBUS_VALIDATE_PATH (path);
  1402       XD_DBUS_VALIDATE_INTERFACE (interface);
  1403       XD_DBUS_VALIDATE_MEMBER (member);
  1404       if (!NILP (handler) && !FUNCTIONP (handler))
  1405         wrong_type_argument (Qinvalid_function, handler);
  1406     }
  1407 
  1408   /* Trace parameters.  */
  1409   switch (mtype)
  1410     {
  1411     case DBUS_MESSAGE_TYPE_METHOD_CALL:
  1412       XD_DEBUG_MESSAGE ("%s %s %s %s %s %s %s",
  1413                         XD_MESSAGE_TYPE_TO_STRING (mtype),
  1414                         XD_OBJECT_TO_STRING (bus),
  1415                         XD_OBJECT_TO_STRING (service),
  1416                         XD_OBJECT_TO_STRING (path),
  1417                         XD_OBJECT_TO_STRING (interface),
  1418                         XD_OBJECT_TO_STRING (member),
  1419                         XD_OBJECT_TO_STRING (handler));
  1420       break;
  1421     case DBUS_MESSAGE_TYPE_SIGNAL:
  1422       XD_DEBUG_MESSAGE ("%s %s %s %s %s %s",
  1423                         XD_MESSAGE_TYPE_TO_STRING (mtype),
  1424                         XD_OBJECT_TO_STRING (bus),
  1425                         XD_OBJECT_TO_STRING (service),
  1426                         XD_OBJECT_TO_STRING (path),
  1427                         XD_OBJECT_TO_STRING (interface),
  1428                         XD_OBJECT_TO_STRING (member));
  1429       break;
  1430     case DBUS_MESSAGE_TYPE_METHOD_RETURN:
  1431       ui_serial = serial;
  1432       XD_DEBUG_MESSAGE ("%s %s %s %u",
  1433                         XD_MESSAGE_TYPE_TO_STRING (mtype),
  1434                         XD_OBJECT_TO_STRING (bus),
  1435                         XD_OBJECT_TO_STRING (service),
  1436                         ui_serial);
  1437        break;
  1438     case DBUS_MESSAGE_TYPE_ERROR:
  1439       ui_serial = serial;
  1440       XD_DEBUG_MESSAGE ("%s %s %s %u %s",
  1441                         XD_MESSAGE_TYPE_TO_STRING (mtype),
  1442                         XD_OBJECT_TO_STRING (bus),
  1443                         XD_OBJECT_TO_STRING (service),
  1444                         ui_serial,
  1445                         XD_OBJECT_TO_STRING (error_name));
  1446       break;
  1447     default: /* DBUS_MESSAGE_TYPE_INVALID  */
  1448       XD_DEBUG_MESSAGE ("%s %s %s",
  1449                         XD_MESSAGE_TYPE_TO_STRING (mtype),
  1450                         XD_OBJECT_TO_STRING (bus),
  1451                         XD_OBJECT_TO_STRING (service));
  1452     }
  1453 
  1454   /* Retrieve bus address.  */
  1455   connection = xd_get_connection_address (bus);
  1456 
  1457   /* Create the D-Bus message.  Since DBUS_MESSAGE_TYPE_INVALID is not
  1458      a valid message type, we mockup it with DBUS_MESSAGE_TYPE_SIGNAL.  */
  1459   dmessage = dbus_message_new
  1460     ((mtype == DBUS_MESSAGE_TYPE_INVALID) ? DBUS_MESSAGE_TYPE_SIGNAL : mtype);
  1461   if (dmessage == NULL)
  1462     XD_SIGNAL1 (build_string ("Unable to create a new message"));
  1463 
  1464   if ((STRINGP (service)) && (mtype != DBUS_MESSAGE_TYPE_INVALID))
  1465     {
  1466       if (mtype != DBUS_MESSAGE_TYPE_SIGNAL)
  1467         /* Set destination.  */
  1468         {
  1469           if (!dbus_message_set_destination (dmessage, SSDATA (service)))
  1470             XD_SIGNAL2 (build_string ("Unable to set the destination"),
  1471                         service);
  1472         }
  1473 
  1474       else
  1475         /* Set destination for unicast signals.  */
  1476         {
  1477           Lisp_Object uname;
  1478 
  1479           /* If it is the same unique name as we are registered at the
  1480              bus or an unknown name, we regard it as broadcast message
  1481              due to backward compatibility.  */
  1482           if (dbus_bus_name_has_owner (connection, SSDATA (service), NULL))
  1483             uname = call2 (intern ("dbus-get-name-owner"), bus, service);
  1484           else
  1485             uname = Qnil;
  1486 
  1487           if (STRINGP (uname)
  1488               && (strcmp (dbus_bus_get_unique_name (connection), SSDATA (uname))
  1489                   != 0)
  1490               && (!dbus_message_set_destination (dmessage, SSDATA (service))))
  1491             XD_SIGNAL2 (build_string ("Unable to set signal destination"),
  1492                         service);
  1493         }
  1494     }
  1495 
  1496   /* Set message parameters.  */
  1497   if ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
  1498       || (mtype == DBUS_MESSAGE_TYPE_SIGNAL))
  1499     {
  1500       if ((!dbus_message_set_path (dmessage, SSDATA (path)))
  1501           || (!dbus_message_set_interface (dmessage, SSDATA (interface)))
  1502           || (!dbus_message_set_member (dmessage, SSDATA (member))))
  1503         XD_SIGNAL1 (build_string ("Unable to set the message parameter"));
  1504     }
  1505 
  1506   else if ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
  1507            || (mtype == DBUS_MESSAGE_TYPE_ERROR))
  1508     {
  1509       if (!dbus_message_set_reply_serial (dmessage, serial))
  1510         XD_SIGNAL1 (build_string ("Unable to create a return message"));
  1511 
  1512       if ((mtype == DBUS_MESSAGE_TYPE_ERROR)
  1513           && (!dbus_message_set_error_name (dmessage, SSDATA (error_name))))
  1514         XD_SIGNAL1 (build_string ("Unable to create an error message"));
  1515     }
  1516 
  1517   /* Check for timeout parameter.  */
  1518   if ((count + 2 <= nargs) && EQ (args[count], QCtimeout))
  1519     {
  1520       CHECK_FIXNAT (args[count+1]);
  1521       timeout = min (XFIXNAT (args[count+1]), INT_MAX);
  1522       count = count+2;
  1523     }
  1524 
  1525   /* Initialize parameter list of message.  */
  1526   dbus_message_iter_init_append (dmessage, &iter);
  1527 
  1528   /* Append parameters to the message.  */
  1529   count0 = count - 1;
  1530   for (; count < nargs; ++count)
  1531     {
  1532       dtype = XD_OBJECT_TO_DBUS_TYPE (args[count]);
  1533       if (count + 1 < nargs && XD_DBUS_TYPE_P (args[count]))
  1534         {
  1535           XD_DEBUG_VALID_LISP_OBJECT_P (args[count]);
  1536           XD_DEBUG_VALID_LISP_OBJECT_P (args[count+1]);
  1537           XD_DEBUG_MESSAGE ("Parameter%"pD"d: %s Parameter%"pD"d: %s",
  1538                             count - count0,
  1539                             XD_OBJECT_TO_STRING (args[count]),
  1540                             count + 1 - count0,
  1541                             XD_OBJECT_TO_STRING (args[count+1]));
  1542           ++count;
  1543         }
  1544       else
  1545         {
  1546           XD_DEBUG_VALID_LISP_OBJECT_P (args[count]);
  1547           XD_DEBUG_MESSAGE ("Parameter%"pD"d: %s", count - count0,
  1548                             XD_OBJECT_TO_STRING (args[count]));
  1549         }
  1550 
  1551       /* Check for valid signature.  We use DBUS_TYPE_INVALID as
  1552          indication that there is no parent type.  */
  1553       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[count]);
  1554 
  1555       xd_append_arg (dtype, args[count], &iter);
  1556     }
  1557 
  1558   if (mtype == DBUS_MESSAGE_TYPE_INVALID)
  1559     result = Qt;
  1560 
  1561   else if (!NILP (handler))
  1562     {
  1563       /* Send the message.  The message is just added to the outgoing
  1564          message queue.  */
  1565       if (!dbus_connection_send_with_reply (connection, dmessage,
  1566                                             NULL, timeout))
  1567         XD_SIGNAL1 (build_string ("Cannot send message"));
  1568 
  1569       /* The result is the key in Vdbus_registered_objects_table.  */
  1570       serial = dbus_message_get_serial (dmessage);
  1571       result = list3 (QCserial, bus, INT_TO_INTEGER (serial));
  1572 
  1573       /* Create a hash table entry.  */
  1574       Fputhash (result, handler, Vdbus_registered_objects_table);
  1575     }
  1576   else
  1577     {
  1578       /* Send the message.  The message is just added to the outgoing
  1579          message queue.  */
  1580       if (!dbus_connection_send (connection, dmessage, NULL))
  1581         XD_SIGNAL1 (build_string ("Cannot send message"));
  1582 
  1583       result = Qnil;
  1584     }
  1585 
  1586   if (mtype != DBUS_MESSAGE_TYPE_INVALID)
  1587     XD_DEBUG_MESSAGE ("Message sent: %s", XD_OBJECT_TO_STRING (result));
  1588 
  1589   /* Cleanup.  */
  1590   dbus_message_unref (dmessage);
  1591 
  1592   /* Return the result.  */
  1593   return result;
  1594 }
  1595 
  1596 /* Read one queued incoming message of the D-Bus BUS.
  1597    BUS is either a Lisp symbol, :system, :session, :system-private or
  1598    :session-private, or a string denoting the bus address.  */
  1599 static void
  1600 xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
  1601 {
  1602   Lisp_Object args, key, value;
  1603   struct input_event event;
  1604   DBusMessage *dmessage;
  1605   DBusMessageIter iter;
  1606   int dtype;
  1607   int mtype;
  1608   dbus_uint32_t serial;
  1609   unsigned int ui_serial;
  1610   const char *uname, *destination, *path, *interface, *member, *error_name;
  1611 
  1612   dmessage = dbus_connection_pop_message (connection);
  1613 
  1614   /* Return if there is no queued message.  */
  1615   if (dmessage == NULL)
  1616     return;
  1617 
  1618   /* Collect the parameters.  */
  1619   args = Qnil;
  1620 
  1621   /* Loop over the resulting parameters.  Construct a list.  */
  1622   if (dbus_message_iter_init (dmessage, &iter))
  1623     {
  1624       while ((dtype = dbus_message_iter_get_arg_type (&iter))
  1625              != DBUS_TYPE_INVALID)
  1626         {
  1627           args = Fcons (xd_retrieve_arg (dtype, &iter), args);
  1628           dbus_message_iter_next (&iter);
  1629         }
  1630       /* The arguments are stored in reverse order.  Reorder them.  */
  1631       args = Fnreverse (args);
  1632     }
  1633 
  1634   /* Read message type, message serial, unique name, object path,
  1635      interface, member and error name from the message.  */
  1636   mtype = dbus_message_get_type (dmessage);
  1637   ui_serial = serial =
  1638     ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
  1639      || (mtype == DBUS_MESSAGE_TYPE_ERROR))
  1640     ? dbus_message_get_reply_serial (dmessage)
  1641     : dbus_message_get_serial (dmessage);
  1642   uname = dbus_message_get_sender (dmessage);
  1643   destination = dbus_message_get_destination (dmessage);
  1644   path = dbus_message_get_path (dmessage);
  1645   interface = dbus_message_get_interface (dmessage);
  1646   member = dbus_message_get_member (dmessage);
  1647   error_name = dbus_message_get_error_name (dmessage);
  1648 
  1649   XD_DEBUG_MESSAGE ("Event received: %s %u %s %s %s %s %s %s",
  1650                     XD_MESSAGE_TYPE_TO_STRING (mtype),
  1651                     ui_serial, uname, destination, path, interface,
  1652                     mtype == DBUS_MESSAGE_TYPE_ERROR ? error_name : member,
  1653                     XD_OBJECT_TO_STRING (args));
  1654 
  1655   if (mtype == DBUS_MESSAGE_TYPE_INVALID)
  1656     goto cleanup;
  1657 
  1658   else if ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
  1659            || (mtype == DBUS_MESSAGE_TYPE_ERROR))
  1660     {
  1661       /* Search for a registered function of the message.  */
  1662       key = list3 (QCserial, bus, INT_TO_INTEGER (serial));
  1663       value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
  1664 
  1665       /* There shall be exactly one entry.  Construct an event.  */
  1666       if (NILP (value))
  1667         goto monitor;
  1668 
  1669       /* Remove the entry.  */
  1670       Fremhash (key, Vdbus_registered_objects_table);
  1671 
  1672       /* Construct an event.  */
  1673       EVENT_INIT (event);
  1674       event.kind = DBUS_EVENT;
  1675       event.frame_or_window = Qnil;
  1676       /* Handler.  */
  1677       event.arg = Fcons (value, args);
  1678     }
  1679 
  1680   else /* DBUS_MESSAGE_TYPE_METHOD_CALL, DBUS_MESSAGE_TYPE_SIGNAL.  */
  1681     {
  1682       /* Vdbus_registered_objects_table requires non-nil interface and
  1683          member.  */
  1684       if ((interface == NULL) || (member == NULL))
  1685         goto monitor;
  1686 
  1687       /* Search for a registered function of the message.  */
  1688       key = list4 (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL ? QCmethod : QCsignal,
  1689                    bus, build_string (interface), build_string (member));
  1690       value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
  1691 
  1692       /* Loop over the registered functions.  Construct an event.  */
  1693       for (; !NILP (value); value = CDR_SAFE (value))
  1694         {
  1695           key = CAR_SAFE (value);
  1696           Lisp_Object key_uname = CAR_SAFE (key);
  1697           /* key has the structure (UNAME SERVICE PATH HANDLER).  */
  1698           if (uname && !NILP (key_uname)
  1699               && strcmp (uname, SSDATA (key_uname)) != 0)
  1700             continue;
  1701           Lisp_Object key_service_etc = CDR_SAFE (key);
  1702           Lisp_Object key_path_etc = CDR_SAFE (key_service_etc);
  1703           Lisp_Object key_path = CAR_SAFE (key_path_etc);
  1704           if (path && !NILP (key_path)
  1705               && strcmp (path, SSDATA (key_path)) != 0)
  1706             continue;
  1707           Lisp_Object handler = CAR_SAFE (CDR_SAFE (key_path_etc));
  1708           if (NILP (handler))
  1709             continue;
  1710 
  1711           /* Construct an event and exit the loop.  */
  1712           EVENT_INIT (event);
  1713           event.kind = DBUS_EVENT;
  1714           event.frame_or_window = Qnil;
  1715           event.arg = Fcons (handler, args);
  1716           break;
  1717         }
  1718 
  1719       if (NILP (value))
  1720         goto monitor;
  1721     }
  1722 
  1723   /* Add type, serial, uname, destination, path, interface and member
  1724      or error_name to the event.  */
  1725   event.arg
  1726     = Fcons (mtype == DBUS_MESSAGE_TYPE_ERROR
  1727              ? error_name == NULL ? Qnil : build_string (error_name)
  1728              : member == NULL ? Qnil : build_string (member),
  1729              event.arg);
  1730   event.arg = Fcons ((interface == NULL ? Qnil : build_string (interface)),
  1731                      event.arg);
  1732   event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
  1733                      event.arg);
  1734   event.arg = Fcons ((destination == NULL ? Qnil : build_string (destination)),
  1735                      event.arg);
  1736   event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
  1737                      event.arg);
  1738   event.arg = Fcons (INT_TO_INTEGER (serial), event.arg);
  1739   event.arg = Fcons (make_fixnum (mtype), event.arg);
  1740 
  1741   /* Add the bus symbol to the event.  */
  1742   event.arg = Fcons (bus, event.arg);
  1743 
  1744   /* Store it into the input event queue.  */
  1745   kbd_buffer_store_event (&event);
  1746 
  1747   XD_DEBUG_MESSAGE ("Event stored: %s", XD_OBJECT_TO_STRING (event.arg));
  1748 
  1749   /* Monitor.  */
  1750  monitor:
  1751   /* Search for a registered function of the message.  */
  1752   key = list2 (QCmonitor, bus);
  1753   value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
  1754 
  1755   /* There shall be exactly one entry.  Construct an event.  */
  1756   if (NILP (value))
  1757     goto cleanup;
  1758 
  1759   /* Construct an event.  */
  1760   EVENT_INIT (event);
  1761   event.kind = DBUS_EVENT;
  1762   event.frame_or_window = Qnil;
  1763 
  1764   /* Add type, serial, uname, destination, path, interface, member
  1765      or error_name and handler to the event.  */
  1766   event.arg
  1767     = Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (CAR_SAFE (value))))),
  1768              args);
  1769   event.arg
  1770     = Fcons (mtype == DBUS_MESSAGE_TYPE_ERROR
  1771              ? error_name == NULL ? Qnil : build_string (error_name)
  1772              : member == NULL ? Qnil : build_string (member),
  1773              event.arg);
  1774   event.arg = Fcons ((interface == NULL ? Qnil : build_string (interface)),
  1775                      event.arg);
  1776   event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
  1777                      event.arg);
  1778   event.arg = Fcons ((destination == NULL ? Qnil : build_string (destination)),
  1779                      event.arg);
  1780   event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
  1781                      event.arg);
  1782   event.arg = Fcons (INT_TO_INTEGER (serial), event.arg);
  1783   event.arg = Fcons (make_fixnum (mtype), event.arg);
  1784 
  1785   /* Add the bus symbol to the event.  */
  1786   event.arg = Fcons (bus, event.arg);
  1787 
  1788   /* Store it into the input event queue.  */
  1789   kbd_buffer_store_event (&event);
  1790 
  1791   XD_DEBUG_MESSAGE ("Monitor event stored: %s", XD_OBJECT_TO_STRING (event.arg));
  1792 
  1793   /* Cleanup.  */
  1794  cleanup:
  1795   dbus_message_unref (dmessage);
  1796 }
  1797 
  1798 /* Read queued incoming messages of the D-Bus BUS.
  1799    BUS is either a Lisp symbol, :system, :session, :system-private or
  1800    :session-private, or a string denoting the bus address.  */
  1801 static Lisp_Object
  1802 xd_read_message (Lisp_Object bus)
  1803 {
  1804   /* Retrieve bus address.  */
  1805   DBusConnection *connection = xd_get_connection_address (bus);
  1806 
  1807   /* Non blocking read of the next available message.  */
  1808   dbus_connection_read_write (connection, 0);
  1809 
  1810   while (dbus_connection_get_dispatch_status (connection)
  1811          != DBUS_DISPATCH_COMPLETE)
  1812     xd_read_message_1 (connection, bus);
  1813   return Qnil;
  1814 }
  1815 
  1816 /* Callback called when something is ready to read or write.  */
  1817 static void
  1818 xd_read_queued_messages (int fd, void *data)
  1819 {
  1820   Lisp_Object busp = xd_registered_buses;
  1821   Lisp_Object bus = Qnil;
  1822   Lisp_Object key;
  1823 
  1824   /* Find bus related to fd.  */
  1825   if (data != NULL)
  1826     while (!NILP (busp))
  1827       {
  1828         key = CAR_SAFE (CAR_SAFE (busp));
  1829         if ((XD_KEYWORDP (key) && XSYMBOL (key) == data)
  1830             || (STRINGP (key) && XSTRING (key) == data))
  1831           bus = key;
  1832         busp = CDR_SAFE (busp);
  1833       }
  1834 
  1835   if (NILP (bus))
  1836     return;
  1837 
  1838   /* We ignore all Lisp errors during the call.  */
  1839   xd_in_read_queued_messages = 1;
  1840   internal_catch (Qdbus_error, xd_read_message, bus);
  1841   xd_in_read_queued_messages = 0;
  1842 }
  1843 
  1844 
  1845 void
  1846 init_dbusbind (void)
  1847 {
  1848   /* We do not want to abort.  */
  1849   xputenv ("DBUS_FATAL_WARNINGS=0");
  1850 }
  1851 
  1852 static void
  1853 syms_of_dbusbind_for_pdumper (void)
  1854 {
  1855   xd_registered_buses = Qnil;
  1856 }
  1857 
  1858 void
  1859 syms_of_dbusbind (void)
  1860 {
  1861   defsubr (&Sdbus__init_bus);
  1862   defsubr (&Sdbus_get_unique_name);
  1863 
  1864   DEFSYM (Qdbus_message_internal, "dbus-message-internal");
  1865   defsubr (&Sdbus_message_internal);
  1866 
  1867   /* D-Bus error symbol.  */
  1868   DEFSYM (Qdbus_error, "dbus-error");
  1869   Fput (Qdbus_error, Qerror_conditions,
  1870         list2 (Qdbus_error, Qerror));
  1871   Fput (Qdbus_error, Qerror_message,
  1872         build_pure_c_string ("D-Bus error"));
  1873 
  1874   /* Lisp symbols of the system and session buses.  */
  1875   DEFSYM (QCsystem, ":system");
  1876   DEFSYM (QCsession, ":session");
  1877   DEFSYM (QCsystem_private, ":system-private");
  1878   DEFSYM (QCsession_private, ":session-private");
  1879 
  1880   /* Lisp symbol for method call timeout.  */
  1881   DEFSYM (QCtimeout, ":timeout");
  1882 
  1883   /* Lisp symbols of D-Bus types.  */
  1884   DEFSYM (QCbyte, ":byte");
  1885   DEFSYM (QCboolean, ":boolean");
  1886   DEFSYM (QCint16, ":int16");
  1887   DEFSYM (QCuint16, ":uint16");
  1888   DEFSYM (QCint32, ":int32");
  1889   DEFSYM (QCuint32, ":uint32");
  1890   DEFSYM (QCint64, ":int64");
  1891   DEFSYM (QCuint64, ":uint64");
  1892   DEFSYM (QCdouble, ":double");
  1893   DEFSYM (QCstring, ":string");
  1894   DEFSYM (QCobject_path, ":object-path");
  1895   DEFSYM (QCsignature, ":signature");
  1896 #ifdef DBUS_TYPE_UNIX_FD
  1897   DEFSYM (QCunix_fd, ":unix-fd");
  1898 #endif
  1899   DEFSYM (QCarray, ":array");
  1900   DEFSYM (QCvariant, ":variant");
  1901   DEFSYM (QCstruct, ":struct");
  1902   DEFSYM (QCdict_entry, ":dict-entry");
  1903 
  1904   /* Lisp symbols of objects in `dbus-registered-objects-table'.
  1905      `:property', which does exist there as well, is not declared here.  */
  1906   DEFSYM (QCserial, ":serial");
  1907   DEFSYM (QCmethod, ":method");
  1908   DEFSYM (QCsignal, ":signal");
  1909   DEFSYM (QCmonitor, ":monitor");
  1910 
  1911   DEFVAR_LISP ("dbus-compiled-version",
  1912                Vdbus_compiled_version,
  1913     doc: /* The version of D-Bus Emacs is compiled against.  */);
  1914 #ifdef DBUS_VERSION_STRING
  1915   Vdbus_compiled_version = build_pure_c_string (DBUS_VERSION_STRING);
  1916 #else
  1917   Vdbus_compiled_version = Qnil;
  1918 #endif
  1919 
  1920   DEFVAR_LISP ("dbus-runtime-version",
  1921                Vdbus_runtime_version,
  1922     doc: /* The version of D-Bus Emacs runs with.  */);
  1923   {
  1924 #ifdef DBUS_VERSION
  1925     int major, minor, micro;
  1926     char s[sizeof ".." + 3 * INT_STRLEN_BOUND (int)];
  1927     dbus_get_version (&major, &minor, &micro);
  1928     Vdbus_runtime_version
  1929       = make_formatted_string (s, "%d.%d.%d", major, minor, micro);
  1930 #else
  1931     Vdbus_runtime_version = Qnil;
  1932 #endif
  1933   }
  1934 
  1935   DEFVAR_LISP ("dbus-message-type-invalid",
  1936                Vdbus_message_type_invalid,
  1937     doc: /* This value is never a valid message type.  */);
  1938   Vdbus_message_type_invalid = make_fixnum (DBUS_MESSAGE_TYPE_INVALID);
  1939 
  1940   DEFVAR_LISP ("dbus-message-type-method-call",
  1941                Vdbus_message_type_method_call,
  1942     doc: /* Message type of a method call message.  */);
  1943   Vdbus_message_type_method_call = make_fixnum (DBUS_MESSAGE_TYPE_METHOD_CALL);
  1944 
  1945   DEFVAR_LISP ("dbus-message-type-method-return",
  1946                Vdbus_message_type_method_return,
  1947     doc: /* Message type of a method return message.  */);
  1948   Vdbus_message_type_method_return
  1949     = make_fixnum (DBUS_MESSAGE_TYPE_METHOD_RETURN);
  1950 
  1951   DEFVAR_LISP ("dbus-message-type-error",
  1952                Vdbus_message_type_error,
  1953     doc: /* Message type of an error reply message.  */);
  1954   Vdbus_message_type_error = make_fixnum (DBUS_MESSAGE_TYPE_ERROR);
  1955 
  1956   DEFVAR_LISP ("dbus-message-type-signal",
  1957                Vdbus_message_type_signal,
  1958     doc: /* Message type of a signal message.  */);
  1959   Vdbus_message_type_signal = make_fixnum (DBUS_MESSAGE_TYPE_SIGNAL);
  1960 
  1961   DEFVAR_LISP ("dbus-registered-objects-table",
  1962                Vdbus_registered_objects_table,
  1963     doc: /* Hash table of registered functions for D-Bus.
  1964 
  1965 There are two different uses of the hash table: for accessing
  1966 registered interfaces properties, targeted by signals, method calls or
  1967 monitors, and for calling handlers in case of non-blocking method call
  1968 returns.
  1969 
  1970 In the first case, the key in the hash table is the list (TYPE BUS
  1971 [INTERFACE MEMBER]).  TYPE is one of the Lisp symbols `:method',
  1972 `:signal', `:property' or `:monitor'.  BUS is either a Lisp symbol,
  1973 `:system', `:session', `:system-private' or `:session-private', or a
  1974 string denoting the bus address.  INTERFACE is a string which denotes
  1975 a D-Bus interface, and MEMBER, also a string, is either a method, a
  1976 signal or a property INTERFACE is offering.  All arguments can be nil.
  1977 
  1978 The value in the hash table is a list of quadruple lists ((UNAME
  1979 SERVICE PATH OBJECT [RULE]) ...).  SERVICE is the service name as
  1980 registered, UNAME is the corresponding unique name.  In case of
  1981 registered methods, properties and monitors, UNAME is nil.  PATH is
  1982 the object path of the sending object.  All of them can be nil, which
  1983 means a wildcard then.
  1984 
  1985 OBJECT is either the handler to be called when a D-Bus message, which
  1986 matches the key criteria, arrives (TYPE `:method', `:signal' and
  1987 `:monitor'), or a list (ACCESS EMITS-SIGNAL VALUE) for TYPE
  1988 `:property'.
  1989 
  1990 For entries of type `:signal' or `:monitor', there is also a fifth
  1991 element RULE, which keeps the match string the signal or monitor is
  1992 registered with.
  1993 
  1994 In the second case, the key in the hash table is the list (:serial BUS
  1995 SERIAL).  BUS is either a Lisp symbol, `:system' or `:session', or a
  1996 string denoting the bus address.  SERIAL is the serial number of the
  1997 non-blocking method call, a reply is expected.  Both arguments must
  1998 not be nil.  The value in the hash table is HANDLER, the function to
  1999 be called when the D-Bus reply message arrives.  */);
  2000   Vdbus_registered_objects_table = CALLN (Fmake_hash_table, QCtest, Qequal);
  2001 
  2002   DEFVAR_LISP ("dbus-debug", Vdbus_debug,
  2003     doc: /* If non-nil, debug messages of D-Bus bindings are raised.  */);
  2004 #ifdef DBUS_DEBUG
  2005   Vdbus_debug = Qt;
  2006   /* We can also set environment variable DBUS_VERBOSE=1 in order to
  2007      see more traces.  This requires libdbus-1 to be configured with
  2008      --enable-verbose-mode.  */
  2009 #else
  2010   Vdbus_debug = Qnil;
  2011 #endif
  2012 
  2013   /* Initialize internal objects.  */
  2014   pdumper_do_now_and_after_load (syms_of_dbusbind_for_pdumper);
  2015   staticpro (&xd_registered_buses);
  2016 
  2017   Fprovide (intern_c_string ("dbusbind"), Qnil);
  2018 }
  2019 
  2020 #endif /* HAVE_DBUS */