src/dbusbind.c

   1 /* Elisp bindings for D-Bus.
   2    Copyright (C) 2007-2013 Free Software Foundation, Inc.
   3
   4 This file is part of GNU Emacs.
   5
   6 GNU Emacs is free software: you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation, either version 3 of the License, or
   9 (at your option) any later version.
  10
  11 GNU Emacs is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
  18
  19 #include <config.h>
  20
  21 #ifdef HAVE_DBUS
  22 #include <stdio.h>
  23 #include <dbus/dbus.h>
  24
  25 #include "lisp.h"
  26 #include "frame.h"
  27 #include "termhooks.h"
  28 #include "keyboard.h"
  29 #include "process.h"
  30
  31 #ifndef DBUS_NUM_MESSAGE_TYPES
  32 #define DBUS_NUM_MESSAGE_TYPES 5
  33 #endif
  34
  35
  36 /* Some platforms define the symbol "interface", but we want to use it
  37  * as a variable name below.  */
  38
  39 #ifdef interface
  40 #undef interface
  41 #endif
  42
  43 \f
  44 /* Subroutines.  */
  45 static Lisp_Object Qdbus_init_bus;
  46 static Lisp_Object Qdbus_get_unique_name;
  47 static Lisp_Object Qdbus_message_internal;
  48
  49 /* D-Bus error symbol.  */
  50 static Lisp_Object Qdbus_error;
  51
  52 /* Lisp symbols of the system and session buses.  */
  53 static Lisp_Object QCdbus_system_bus, QCdbus_session_bus;
  54
  55 /* Lisp symbol for method call timeout.  */
  56 static Lisp_Object QCdbus_timeout;
  57
  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;
  67 #endif
  68 static Lisp_Object QCdbus_type_array, QCdbus_type_variant;
  69 static Lisp_Object QCdbus_type_struct, QCdbus_type_dict_entry;
  70
  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;
  74
  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;
  79
  80 /* Whether we are reading a D-Bus event.  */
  81 static bool xd_in_read_queued_messages = 0;
  82
  83 \f
  84 /* We use "xd_" and "XD_" as prefix for all internal symbols, because
  85    we don't want to poison other namespaces with "dbus_".  */
  86
  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)                                                 \
  90   do {                                                                  \
  91     if (xd_in_read_queued_messages)                                     \
  92       Fthrow (Qdbus_error, Qnil);                                       \
  93     else                                                                \
  94       xsignal1 (Qdbus_error, arg);                                      \
  95   } while (0)
  96
  97 #define XD_SIGNAL2(arg1, arg2)                                          \
  98   do {                                                                  \
  99     if (xd_in_read_queued_messages)                                     \
 100       Fthrow (Qdbus_error, Qnil);                                       \
 101     else                                                                \
 102       xsignal2 (Qdbus_error, arg1, arg2);                               \
 103   } while (0)
 104
 105 #define XD_SIGNAL3(arg1, arg2, arg3)                                    \
 106   do {                                                                  \
 107     if (xd_in_read_queued_messages)                                     \
 108       Fthrow (Qdbus_error, Qnil);                                       \
 109     else                                                                \
 110       xsignal3 (Qdbus_error, arg1, arg2, arg3);                         \
 111   } while (0)
 112
 113 /* Raise a Lisp error from a D-Bus ERROR.  */
 114 #define XD_ERROR(error)                                                 \
 115   do {                                                                  \
 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);                                           \
 121     XD_SIGNAL1 (err);                                                   \
 122   } while (0)
 123
 124 /* Macros for debugging.  In order to enable them, build with
 125    "env MYCPPFLAGS='-DDBUS_DEBUG -Wall' make".  */
 126 #ifdef DBUS_DEBUG
 127 #define XD_DEBUG_MESSAGE(...)                                           \
 128   do {                                                                  \
 129     char s[1024];                                                       \
 130     snprintf (s, sizeof s, __VA_ARGS__);                                \
 131     if (!noninteractive)                                                \
 132       printf ("%s: %s\n", __func__, s);                                 \
 133     message ("%s: %s", __func__, s);                                    \
 134   } while (0)
 135 #define XD_DEBUG_VALID_LISP_OBJECT_P(object)                            \
 136   do {                                                                  \
 137     if (!valid_lisp_object_p (object))                                  \
 138       {                                                                 \
 139         XD_DEBUG_MESSAGE ("%d Assertion failure", __LINE__);            \
 140         XD_SIGNAL1 (build_string ("Assertion failure"));                \
 141       }                                                                 \
 142   } while (0)
 143
 144 #else /* !DBUS_DEBUG */
 145 #define XD_DEBUG_MESSAGE(...)                                           \
 146   do {                                                                  \
 147     if (!NILP (Vdbus_debug))                                            \
 148       {                                                                 \
 149         char s[1024];                                                   \
 150         snprintf (s, sizeof s, __VA_ARGS__);                            \
 151         message ("%s: %s", __func__, s);                                \
 152       }                                                                 \
 153   } while (0)
 154 #define XD_DEBUG_VALID_LISP_OBJECT_P(object)
 155 #endif
 156
 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))
 161 #else
 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))
 177 #else
 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))
 191 #endif
 192 #endif
 193
 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
 196    a function.  */
 197 /* Determine the DBusType of a given Lisp symbol.  OBJECT must be one
 198    of the predefined D-Bus type symbols.  */
 199 static int
 200 xd_symbol_to_dbus_type (Lisp_Object object)
 201 {
 202   return
 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
 217 #endif
 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);
 223 }
 224
 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)))
 228
 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)        \
 240    : (CONSP (object))                                                   \
 241    ? ((XD_DBUS_TYPE_P (CAR_SAFE (object)))                              \
 242       ? ((XD_BASIC_DBUS_TYPE (xd_symbol_to_dbus_type (CAR_SAFE (object)))) \
 243          ? DBUS_TYPE_ARRAY                                              \
 244          : xd_symbol_to_dbus_type (CAR_SAFE (object)))                  \
 245       : DBUS_TYPE_ARRAY)                                                \
 246    : DBUS_TYPE_INVALID)
 247
 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)
 251
 252 /* Transform the message type to its string representation for debug
 253    messages.  */
 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")
 264
 265 /* Transform the object to its string representation for debug
 266    messages.  */
 267 #define XD_OBJECT_TO_STRING(object)                                     \
 268   SDATA (format2 ("%s", object, Qnil))
 269
 270 #define XD_DBUS_VALIDATE_BUS_ADDRESS(bus)                               \
 271   do {                                                                  \
 272     char const *session_bus_address = getenv ("DBUS_SESSION_BUS_ADDRESS"); \
 273     if (STRINGP (bus))                                                  \
 274       {                                                                 \
 275         DBusAddressEntry **entries;                                     \
 276         int len;                                                        \
 277         DBusError derror;                                               \
 278         dbus_error_init (&derror);                                      \
 279         if (!dbus_parse_address (SSDATA (bus), &entries, &len, &derror)) \
 280           XD_ERROR (derror);                                            \
 281         /* Cleanup.  */                                                 \
 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;                                     \
 289       }                                                                 \
 290                                                                         \
 291     else                                                                \
 292       {                                                                 \
 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);      \
 299       }                                                                 \
 300   } while (0)
 301
 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)                           \
 305   do {                                                                  \
 306     if (!NILP (object))                                                 \
 307       {                                                                 \
 308         DBusError derror;                                               \
 309         CHECK_STRING (object);                                          \
 310         dbus_error_init (&derror);                                      \
 311         if (!func (SSDATA (object), &derror))                           \
 312           XD_ERROR (derror);                                            \
 313         /* Cleanup.  */                                                 \
 314         dbus_error_free (&derror);                                      \
 315       }                                                                 \
 316   } while (0)
 317 #endif
 318
 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);
 322 #else
 323 #define XD_DBUS_VALIDATE_BUS_NAME(bus_name)                             \
 324   if (!NILP (bus_name)) CHECK_STRING (bus_name);
 325 #endif
 326
 327 #if HAVE_DBUS_VALIDATE_PATH
 328 #define XD_DBUS_VALIDATE_PATH(path)                                     \
 329   XD_DBUS_VALIDATE_OBJECT(path, dbus_validate_path);
 330 #else
 331 #define XD_DBUS_VALIDATE_PATH(path)                                     \
 332   if (!NILP (path)) CHECK_STRING (path);
 333 #endif
 334
 335 #if HAVE_DBUS_VALIDATE_INTERFACE
 336 #define XD_DBUS_VALIDATE_INTERFACE(interface)                           \
 337   XD_DBUS_VALIDATE_OBJECT(interface, dbus_validate_interface);
 338 #else
 339 #define XD_DBUS_VALIDATE_INTERFACE(interface)                           \
 340   if (!NILP (interface)) CHECK_STRING (interface);
 341 #endif
 342
 343 #if HAVE_DBUS_VALIDATE_MEMBER
 344 #define XD_DBUS_VALIDATE_MEMBER(member)                                 \
 345   XD_DBUS_VALIDATE_OBJECT(member, dbus_validate_member);
 346 #else
 347 #define XD_DBUS_VALIDATE_MEMBER(member)                                 \
 348   if (!NILP (member)) CHECK_STRING (member);
 349 #endif
 350
 351 /* Append to SIGNATURE a copy of X, making sure SIGNATURE does
 352    not become too long.  */
 353 static void
 354 xd_signature_cat (char *signature, char const *x)
 355 {
 356   ptrdiff_t siglen = strlen (signature);
 357   ptrdiff_t xlen = strlen (x);
 358   if (DBUS_MAXIMUM_SIGNATURE_LENGTH - xlen <= siglen)
 359     string_overflow ();
 360   strcat (signature, x);
 361 }
 362
 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.  */
 370 static void
 371 xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object)
 372 {
 373   int subtype;
 374   Lisp_Object elt;
 375   char const *subsig;
 376   int subsiglen;
 377   char x[DBUS_MAXIMUM_SIGNATURE_LENGTH];
 378
 379   elt = object;
 380
 381   switch (dtype)
 382     {
 383     case DBUS_TYPE_BYTE:
 384     case DBUS_TYPE_UINT16:
 385       CHECK_NATNUM (object);
 386       sprintf (signature, "%c", dtype);
 387       break;
 388
 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);
 393       break;
 394
 395     case DBUS_TYPE_INT16:
 396       CHECK_NUMBER (object);
 397       sprintf (signature, "%c", dtype);
 398       break;
 399
 400     case DBUS_TYPE_UINT32:
 401     case DBUS_TYPE_UINT64:
 402 #ifdef DBUS_TYPE_UNIX_FD
 403     case DBUS_TYPE_UNIX_FD:
 404 #endif
 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);
 410       break;
 411
 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);
 417       break;
 418
 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.  */
 423       CHECK_CONS (object);
 424
 425       /* Type symbol is optional.  */
 426       if (EQ (QCdbus_type_array, CAR_SAFE (elt)))
 427         elt = XD_NEXT_VALUE (elt);
 428
 429       /* If the array is empty, DBUS_TYPE_STRING is the default
 430          element type.  */
 431       if (NILP (elt))
 432         {
 433           subtype = DBUS_TYPE_STRING;
 434           subsig = DBUS_TYPE_STRING_AS_STRING;
 435         }
 436       else
 437         {
 438           subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
 439           xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
 440           subsig = x;
 441         }
 442
 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)));
 450
 451       while (!NILP (elt))
 452         {
 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));
 456         }
 457
 458       subsiglen = snprintf (signature, DBUS_MAXIMUM_SIGNATURE_LENGTH,
 459                             "%c%s", dtype, subsig);
 460       if (! (0 <= subsiglen && subsiglen < DBUS_MAXIMUM_SIGNATURE_LENGTH))
 461         string_overflow ();
 462       break;
 463
 464     case DBUS_TYPE_VARIANT:
 465       /* Check that there is exactly one list element.  */
 466       CHECK_CONS (object);
 467
 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)));
 471
 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))));
 475
 476       sprintf (signature, "%c", dtype);
 477       break;
 478
 479     case DBUS_TYPE_STRUCT:
 480       /* A struct list might contain any number of elements with
 481          different types.  No further check needed.  */
 482       CHECK_CONS (object);
 483
 484       elt = XD_NEXT_VALUE (elt);
 485
 486       /* Compose the signature from the elements.  It is enclosed by
 487          parentheses.  */
 488       sprintf (signature, "%c", DBUS_STRUCT_BEGIN_CHAR );
 489       while (!NILP (elt))
 490         {
 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));
 495         }
 496       xd_signature_cat (signature, DBUS_STRUCT_END_CHAR_AS_STRING);
 497       break;
 498
 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.  */
 503       CHECK_CONS (object);
 504
 505       /* Check the parent object type.  */
 506       if (parent_type != DBUS_TYPE_ARRAY)
 507         wrong_type_argument (intern ("D-Bus"), object);
 508
 509       /* Compose the signature from the elements.  It is enclosed by
 510          curly braces.  */
 511       sprintf (signature, "%c", DBUS_DICT_ENTRY_BEGIN_CHAR);
 512
 513       /* First element.  */
 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);
 518
 519       if (!XD_BASIC_DBUS_TYPE (subtype))
 520         wrong_type_argument (intern ("D-Bus"), CAR_SAFE (XD_NEXT_VALUE (elt)));
 521
 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);
 527
 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))));
 531
 532       /* Closing signature.  */
 533       xd_signature_cat (signature, DBUS_DICT_ENTRY_END_CHAR_AS_STRING);
 534       break;
 535
 536     default:
 537       wrong_type_argument (intern ("D-Bus"), object);
 538     }
 539
 540   XD_DEBUG_MESSAGE ("%s", signature);
 541 }
 542
 543 /* Convert X to a signed integer with bounds LO and HI.  */
 544 static intmax_t
 545 xd_extract_signed (Lisp_Object x, intmax_t lo, intmax_t hi)
 546 {
 547   CHECK_NUMBER_OR_FLOAT (x);
 548   if (INTEGERP (x))
 549     {
 550       if (lo <= XINT (x) && XINT (x) <= hi)
 551         return XINT (x);
 552     }
 553   else
 554     {
 555       double d = XFLOAT_DATA (x);
 556       if (lo <= d && d <= hi)
 557         {
 558           intmax_t n = d;
 559           if (n == d)
 560             return n;
 561         }
 562     }
 563   if (xd_in_read_queued_messages)
 564     Fthrow (Qdbus_error, Qnil);
 565   else
 566     args_out_of_range_3 (x,
 567                          make_fixnum_or_float (lo),
 568                          make_fixnum_or_float (hi));
 569 }
 570
 571 /* Convert X to an unsigned integer with bounds 0 and HI.  */
 572 static uintmax_t
 573 xd_extract_unsigned (Lisp_Object x, uintmax_t hi)
 574 {
 575   CHECK_NUMBER_OR_FLOAT (x);
 576   if (INTEGERP (x))
 577     {
 578       if (0 <= XINT (x) && XINT (x) <= hi)
 579         return XINT (x);
 580     }
 581   else
 582     {
 583       double d = XFLOAT_DATA (x);
 584       if (0 <= d && d <= hi)
 585         {
 586           uintmax_t n = d;
 587           if (n == d)
 588             return n;
 589         }
 590     }
 591   if (xd_in_read_queued_messages)
 592     Fthrow (Qdbus_error, Qnil);
 593   else
 594     args_out_of_range_3 (x, make_number (0), make_fixnum_or_float (hi));
 595 }
 596
 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.  */
 602 static void
 603 xd_append_arg (int dtype, Lisp_Object object, DBusMessageIter *iter)
 604 {
 605   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
 606   DBusMessageIter subiter;
 607
 608   if (XD_BASIC_DBUS_TYPE (dtype))
 609     switch (dtype)
 610       {
 611       case DBUS_TYPE_BYTE:
 612         CHECK_NATNUM (object);
 613         {
 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);
 618           return;
 619         }
 620
 621       case DBUS_TYPE_BOOLEAN:
 622         {
 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);
 627           return;
 628         }
 629
 630       case DBUS_TYPE_INT16:
 631         {
 632           dbus_int16_t val =
 633             xd_extract_signed (object,
 634                                TYPE_MINIMUM (dbus_int16_t),
 635                                TYPE_MAXIMUM (dbus_int16_t));
 636           int pval = val;
 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);
 640           return;
 641         }
 642
 643       case DBUS_TYPE_UINT16:
 644         {
 645           dbus_uint16_t val =
 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);
 652           return;
 653         }
 654
 655       case DBUS_TYPE_INT32:
 656         {
 657           dbus_int32_t val =
 658             xd_extract_signed (object,
 659                                TYPE_MINIMUM (dbus_int32_t),
 660                                TYPE_MAXIMUM (dbus_int32_t));
 661           int pval = val;
 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);
 665           return;
 666         }
 667
 668       case DBUS_TYPE_UINT32:
 669 #ifdef DBUS_TYPE_UNIX_FD
 670       case DBUS_TYPE_UNIX_FD:
 671 #endif
 672         {
 673           dbus_uint32_t val =
 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);
 680           return;
 681         }
 682
 683       case DBUS_TYPE_INT64:
 684         {
 685           dbus_int64_t val =
 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);
 693           return;
 694         }
 695
 696       case DBUS_TYPE_UINT64:
 697         {
 698           dbus_uint64_t val =
 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);
 705           return;
 706         }
 707
 708       case DBUS_TYPE_DOUBLE:
 709         {
 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);
 714           return;
 715         }
 716
 717       case DBUS_TYPE_STRING:
 718       case DBUS_TYPE_OBJECT_PATH:
 719       case DBUS_TYPE_SIGNATURE:
 720         CHECK_STRING (object);
 721         {
 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);
 730           return;
 731         }
 732       }
 733
 734   else /* Compound types.  */
 735     {
 736
 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);
 741
 742       /* Open new subiteration.  */
 743       switch (dtype)
 744         {
 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
 748              only.  */
 749
 750           if (NILP (object))
 751             /* If the array is empty, DBUS_TYPE_STRING is the default
 752                element type.  */
 753             strcpy (signature, DBUS_TYPE_STRING_AS_STRING);
 754
 755           else
 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))))
 763               {
 764                 strcpy (signature, SSDATA (CAR_SAFE (XD_NEXT_VALUE (object))));
 765                 object = CDR_SAFE (XD_NEXT_VALUE (object));
 766               }
 767
 768             else
 769               xd_signature (signature,
 770                             XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object)),
 771                             dtype, CAR_SAFE (XD_NEXT_VALUE (object)));
 772
 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));
 779           break;
 780
 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)));
 785
 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));
 792           break;
 793
 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));
 801           break;
 802         }
 803
 804       /* Loop over list elements.  */
 805       while (!NILP (object))
 806         {
 807           dtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object));
 808           object = XD_NEXT_VALUE (object);
 809
 810           xd_append_arg (dtype, CAR_SAFE (object), &subiter);
 811
 812           object = CDR_SAFE (object);
 813         }
 814
 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));
 819     }
 820 }
 821
 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.  */
 826 static Lisp_Object
 827 xd_retrieve_arg (int dtype, DBusMessageIter *iter)
 828 {
 829
 830   switch (dtype)
 831     {
 832     case DBUS_TYPE_BYTE:
 833       {
 834         unsigned int val;
 835         dbus_message_iter_get_basic (iter, &val);
 836         val = val & 0xFF;
 837         XD_DEBUG_MESSAGE ("%c %u", dtype, val);
 838         return make_number (val);
 839       }
 840
 841     case DBUS_TYPE_BOOLEAN:
 842       {
 843         dbus_bool_t val;
 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;
 847       }
 848
 849     case DBUS_TYPE_INT16:
 850       {
 851         dbus_int16_t val;
 852         int pval;
 853         dbus_message_iter_get_basic (iter, &val);
 854         pval = val;
 855         XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
 856         return make_number (val);
 857       }
 858
 859     case DBUS_TYPE_UINT16:
 860       {
 861         dbus_uint16_t val;
 862         int pval;
 863         dbus_message_iter_get_basic (iter, &val);
 864         pval = val;
 865         XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
 866         return make_number (val);
 867       }
 868
 869     case DBUS_TYPE_INT32:
 870       {
 871         dbus_int32_t val;
 872         int pval;
 873         dbus_message_iter_get_basic (iter, &val);
 874         pval = val;
 875         XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
 876         return make_fixnum_or_float (val);
 877       }
 878
 879     case DBUS_TYPE_UINT32:
 880 #ifdef DBUS_TYPE_UNIX_FD
 881     case DBUS_TYPE_UNIX_FD:
 882 #endif
 883       {
 884         dbus_uint32_t val;
 885         unsigned int pval;
 886         dbus_message_iter_get_basic (iter, &val);
 887         pval = val;
 888         XD_DEBUG_MESSAGE ("%c %u", dtype, pval);
 889         return make_fixnum_or_float (val);
 890       }
 891
 892     case DBUS_TYPE_INT64:
 893       {
 894         dbus_int64_t val;
 895         printmax_t pval;
 896         dbus_message_iter_get_basic (iter, &val);
 897         pval = val;
 898         XD_DEBUG_MESSAGE ("%c %"pMd, dtype, pval);
 899         return make_fixnum_or_float (val);
 900       }
 901
 902     case DBUS_TYPE_UINT64:
 903       {
 904         dbus_uint64_t val;
 905         uprintmax_t pval;
 906         dbus_message_iter_get_basic (iter, &val);
 907         pval = val;
 908         XD_DEBUG_MESSAGE ("%c %"pMd, dtype, pval);
 909         return make_fixnum_or_float (val);
 910       }
 911
 912     case DBUS_TYPE_DOUBLE:
 913       {
 914         double val;
 915         dbus_message_iter_get_basic (iter, &val);
 916         XD_DEBUG_MESSAGE ("%c %f", dtype, val);
 917         return make_float (val);
 918       }
 919
 920     case DBUS_TYPE_STRING:
 921     case DBUS_TYPE_OBJECT_PATH:
 922     case DBUS_TYPE_SIGNATURE:
 923       {
 924         char *val;
 925         dbus_message_iter_get_basic (iter, &val);
 926         XD_DEBUG_MESSAGE ("%c %s", dtype, val);
 927         return build_string (val);
 928       }
 929
 930     case DBUS_TYPE_ARRAY:
 931     case DBUS_TYPE_VARIANT:
 932     case DBUS_TYPE_STRUCT:
 933     case DBUS_TYPE_DICT_ENTRY:
 934       {
 935         Lisp_Object result;
 936         struct gcpro gcpro1;
 937         DBusMessageIter subiter;
 938         int subtype;
 939         result = Qnil;
 940         GCPRO1 (result);
 941         dbus_message_iter_recurse (iter, &subiter);
 942         while ((subtype = dbus_message_iter_get_arg_type (&subiter))
 943                != DBUS_TYPE_INVALID)
 944           {
 945             result = Fcons (xd_retrieve_arg (subtype, &subiter), result);
 946             dbus_message_iter_next (&subiter);
 947           }
 948         XD_DEBUG_MESSAGE ("%c %s", dtype, XD_OBJECT_TO_STRING (result));
 949         RETURN_UNGCPRO (Fnreverse (result));
 950       }
 951
 952     default:
 953       XD_DEBUG_MESSAGE ("DBusType '%c' not supported", dtype);
 954       return Qnil;
 955     }
 956 }
 957
 958 /* Return the number of references of the shared CONNECTION.  */
 959 static ptrdiff_t
 960 xd_get_connection_references (DBusConnection *connection)
 961 {
 962   ptrdiff_t *refcount;
 963
 964   /* We cannot access the DBusConnection structure, it is not public.
 965      But we know, that the reference counter is the first field in
 966      that structure.  */
 967   refcount = (void *) &connection;
 968   refcount =  (void *) *refcount;
 969   return *refcount;
 970 }
 971
 972 /* Return D-Bus connection address.  BUS is either a Lisp symbol,
 973    :system or :session, or a string denoting the bus address.  */
 974 static DBusConnection *
 975 xd_get_connection_address (Lisp_Object bus)
 976 {
 977   DBusConnection *connection;
 978   Lisp_Object val;
 979
 980   val = CDR_SAFE (Fassoc (bus, xd_registered_buses));
 981   if (NILP (val))
 982     XD_SIGNAL2 (build_string ("No connection to bus"), bus);
 983   else
 984     connection = (DBusConnection *) (intptr_t) XFASTINT (val);
 985
 986   if (!dbus_connection_get_is_connected (connection))
 987     XD_SIGNAL2 (build_string ("No connection to bus"), bus);
 988
 989   return connection;
 990 }
 991
 992 /* Return the file descriptor for WATCH, -1 if not found.  */
 993 static int
 994 xd_find_watch_fd (DBusWatch *watch)
 995 {
 996 #if HAVE_DBUS_WATCH_GET_UNIX_FD
 997   /* TODO: Reverse these on w32, which prefers the opposite.  */
 998   int fd = dbus_watch_get_unix_fd (watch);
 999   if (fd == -1)
1000     fd = dbus_watch_get_socket (watch);
1001 #else
1002   int fd = dbus_watch_get_fd (watch);
1003 #endif
1004   return fd;
1005 }
1006
1007 /* Prototype.  */
1008 static void xd_read_queued_messages (int fd, void *data);
1009
1010 /* Start monitoring WATCH for possible I/O.  */
1011 static dbus_bool_t
1012 xd_add_watch (DBusWatch *watch, void *data)
1013 {
1014   unsigned int flags = dbus_watch_get_flags (watch);
1015   int fd = xd_find_watch_fd (watch);
1016
1017   XD_DEBUG_MESSAGE ("fd %d, write %d, enabled %d",
1018                     fd, flags & DBUS_WATCH_WRITABLE,
1019                     dbus_watch_get_enabled (watch));
1020
1021   if (fd == -1)
1022     return FALSE;
1023
1024   if (dbus_watch_get_enabled (watch))
1025     {
1026       if (flags & DBUS_WATCH_WRITABLE)
1027         add_write_fd (fd, xd_read_queued_messages, data);
1028       if (flags & DBUS_WATCH_READABLE)
1029         add_read_fd (fd, xd_read_queued_messages, data);
1030     }
1031   return TRUE;
1032 }
1033
1034 /* Stop monitoring WATCH for possible I/O.
1035    DATA is the used bus, either a string or QCdbus_system_bus or
1036    QCdbus_session_bus.  */
1037 static void
1038 xd_remove_watch (DBusWatch *watch, void *data)
1039 {
1040   unsigned int flags = dbus_watch_get_flags (watch);
1041   int fd = xd_find_watch_fd (watch);
1042
1043   XD_DEBUG_MESSAGE ("fd %d", fd);
1044
1045   if (fd == -1)
1046     return;
1047
1048   /* Unset session environment.  */
1049 #if 0
1050   if (XSYMBOL (QCdbus_session_bus) == data)
1051     {
1052       XD_DEBUG_MESSAGE ("unsetenv DBUS_SESSION_BUS_ADDRESS");
1053       unsetenv ("DBUS_SESSION_BUS_ADDRESS");
1054     }
1055 #endif
1056
1057   if (flags & DBUS_WATCH_WRITABLE)
1058     delete_write_fd (fd);
1059   if (flags & DBUS_WATCH_READABLE)
1060     delete_read_fd (fd);
1061 }
1062
1063 /* Toggle monitoring WATCH for possible I/O.  */
1064 static void
1065 xd_toggle_watch (DBusWatch *watch, void *data)
1066 {
1067   if (dbus_watch_get_enabled (watch))
1068     xd_add_watch (watch, data);
1069   else
1070     xd_remove_watch (watch, data);
1071 }
1072
1073 /* Close connection to D-Bus BUS.  */
1074 static void
1075 xd_close_bus (Lisp_Object bus)
1076 {
1077   DBusConnection *connection;
1078   Lisp_Object val;
1079
1080   /* Check whether we are connected.  */
1081   val = Fassoc (bus, xd_registered_buses);
1082   if (NILP (val))
1083     return;
1084
1085   /* Retrieve bus address.  */
1086   connection = xd_get_connection_address (bus);
1087
1088   if (xd_get_connection_references (connection) == 1)
1089     {
1090       /* Close connection, if there isn't another shared application.  */
1091       XD_DEBUG_MESSAGE ("Close connection to bus %s",
1092                         XD_OBJECT_TO_STRING (bus));
1093       dbus_connection_close (connection);
1094
1095       xd_registered_buses = Fdelete (val, xd_registered_buses);
1096     }
1097
1098   else
1099     /* Decrement reference count.  */
1100     dbus_connection_unref (connection);
1101
1102   /* Return.  */
1103   return;
1104 }
1105
1106 DEFUN ("dbus-init-bus", Fdbus_init_bus, Sdbus_init_bus, 1, 2, 0,
1107        doc: /* Establish the connection to D-Bus BUS.
1108
1109 BUS can be either the symbol `:system' or the symbol `:session', or it
1110 can be a string denoting the address of the corresponding bus.  For
1111 the system and session buses, this function is called when loading
1112 `dbus.el', there is no need to call it again.
1113
1114 The function returns a number, which counts the connections this Emacs
1115 session has established to the BUS under the same unique name (see
1116 `dbus-get-unique-name').  It depends on the libraries Emacs is linked
1117 with, and on the environment Emacs is running.  For example, if Emacs
1118 is linked with the gtk toolkit, and it runs in a GTK-aware environment
1119 like Gnome, another connection might already be established.
1120
1121 When PRIVATE is non-nil, a new connection is established instead of
1122 reusing an existing one.  It results in a new unique name at the bus.
1123 This can be used, if it is necessary to distinguish from another
1124 connection used in the same Emacs process, like the one established by
1125 GTK+.  It should be used with care for at least the `:system' and
1126 `:session' buses, because other Emacs Lisp packages might already use
1127 this connection to those buses.  */)
1128   (Lisp_Object bus, Lisp_Object private)
1129 {
1130   DBusConnection *connection;
1131   DBusError derror;
1132   Lisp_Object val;
1133   ptrdiff_t refcount;
1134
1135   /* Check parameter.  */
1136   XD_DBUS_VALIDATE_BUS_ADDRESS (bus);
1137
1138   /* Close bus if it is already open.  */
1139   xd_close_bus (bus);
1140
1141   /* Check, whether we are still connected.  */
1142   val = Fassoc (bus, xd_registered_buses);
1143   if (!NILP (val))
1144     {
1145       connection = xd_get_connection_address (bus);
1146       dbus_connection_ref (connection);
1147     }
1148
1149   else
1150     {
1151       /* Initialize.  */
1152       dbus_error_init (&derror);
1153
1154       /* Open the connection.  */
1155       if (STRINGP (bus))
1156         if (NILP (private))
1157           connection = dbus_connection_open (SSDATA (bus), &derror);
1158         else
1159           connection = dbus_connection_open_private (SSDATA (bus), &derror);
1160
1161       else
1162         if (NILP (private))
1163           connection = dbus_bus_get (EQ (bus, QCdbus_system_bus)
1164                                      ? DBUS_BUS_SYSTEM : DBUS_BUS_SESSION,
1165                                      &derror);
1166         else
1167           connection = dbus_bus_get_private (EQ (bus, QCdbus_system_bus)
1168                                              ? DBUS_BUS_SYSTEM : DBUS_BUS_SESSION,
1169                                              &derror);
1170
1171       if (dbus_error_is_set (&derror))
1172         XD_ERROR (derror);
1173
1174       if (connection == NULL)
1175         XD_SIGNAL2 (build_string ("No connection to bus"), bus);
1176
1177       /* If it is not the system or session bus, we must register
1178          ourselves.  Otherwise, we have called dbus_bus_get, which has
1179          configured us to exit if the connection closes - we undo this
1180          setting.  */
1181       if (STRINGP (bus))
1182         dbus_bus_register (connection, &derror);
1183       else
1184         dbus_connection_set_exit_on_disconnect (connection, FALSE);
1185
1186       if (dbus_error_is_set (&derror))
1187         XD_ERROR (derror);
1188
1189       /* Add the watch functions.  We pass also the bus as data, in
1190          order to distinguish between the buses in xd_remove_watch.  */
1191       if (!dbus_connection_set_watch_functions (connection,
1192                                                 xd_add_watch,
1193                                                 xd_remove_watch,
1194                                                 xd_toggle_watch,
1195                                                 SYMBOLP (bus)
1196                                                 ? (void *) XSYMBOL (bus)
1197                                                 : (void *) XSTRING (bus),
1198                                                 NULL))
1199         XD_SIGNAL1 (build_string ("Cannot add watch functions"));
1200
1201       /* Add bus to list of registered buses.  */
1202       XSETFASTINT (val, (intptr_t) connection);
1203       xd_registered_buses = Fcons (Fcons (bus, val), xd_registered_buses);
1204
1205       /* We do not want to abort.  */
1206       xputenv ("DBUS_FATAL_WARNINGS=0");
1207
1208       /* Cleanup.  */
1209       dbus_error_free (&derror);
1210     }
1211
1212   /* Return reference counter.  */
1213   refcount = xd_get_connection_references (connection);
1214   XD_DEBUG_MESSAGE ("Bus %s, Reference counter %"pD"d",
1215                     XD_OBJECT_TO_STRING (bus), refcount);
1216   return make_number (refcount);
1217 }
1218
1219 DEFUN ("dbus-get-unique-name", Fdbus_get_unique_name, Sdbus_get_unique_name,
1220        1, 1, 0,
1221        doc: /* Return the unique name of Emacs registered at D-Bus BUS.  */)
1222   (Lisp_Object bus)
1223 {
1224   DBusConnection *connection;
1225   const char *name;
1226
1227   /* Check parameter.  */
1228   XD_DBUS_VALIDATE_BUS_ADDRESS (bus);
1229
1230   /* Retrieve bus address.  */
1231   connection = xd_get_connection_address (bus);
1232
1233   /* Request the name.  */
1234   name = dbus_bus_get_unique_name (connection);
1235   if (name == NULL)
1236     XD_SIGNAL1 (build_string ("No unique name available"));
1237
1238   /* Return.  */
1239   return build_string (name);
1240 }
1241
1242 DEFUN ("dbus-message-internal", Fdbus_message_internal, Sdbus_message_internal,
1243        4, MANY, 0,
1244        doc: /* Send a D-Bus message.
1245 This is an internal function, it shall not be used outside dbus.el.
1246
1247 The following usages are expected:
1248
1249 `dbus-call-method', `dbus-call-method-asynchronously':
1250   \(dbus-message-internal
1251     dbus-message-type-method-call BUS SERVICE PATH INTERFACE METHOD HANDLER
1252     &optional :timeout TIMEOUT &rest ARGS)
1253
1254 `dbus-send-signal':
1255   \(dbus-message-internal
1256     dbus-message-type-signal BUS SERVICE PATH INTERFACE SIGNAL &rest ARGS)
1257
1258 `dbus-method-return-internal':
1259   \(dbus-message-internal
1260     dbus-message-type-method-return BUS SERVICE SERIAL &rest ARGS)
1261
1262 `dbus-method-error-internal':
1263   \(dbus-message-internal
1264     dbus-message-type-error BUS SERVICE SERIAL &rest ARGS)
1265
1266 usage: (dbus-message-internal &rest REST)  */)
1267   (ptrdiff_t nargs, Lisp_Object *args)
1268 {
1269   Lisp_Object message_type, bus, service, handler;
1270   Lisp_Object path = Qnil;
1271   Lisp_Object interface = Qnil;
1272   Lisp_Object member = Qnil;
1273   Lisp_Object result;
1274   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5, gcpro6;
1275   DBusConnection *connection;
1276   DBusMessage *dmessage;
1277   DBusMessageIter iter;
1278   int dtype;
1279   int mtype;
1280   dbus_uint32_t serial = 0;
1281   unsigned int ui_serial;
1282   int timeout = -1;
1283   ptrdiff_t count;
1284   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1285
1286   /* Initialize parameters.  */
1287   message_type = args[0];
1288   bus = args[1];
1289   service = args[2];
1290   handler = Qnil;
1291
1292   CHECK_NATNUM (message_type);
1293   if (! (DBUS_MESSAGE_TYPE_INVALID < XFASTINT (message_type)
1294          && XFASTINT (message_type) < DBUS_NUM_MESSAGE_TYPES))
1295     XD_SIGNAL2 (build_string ("Invalid message type"), message_type);
1296   mtype = XFASTINT (message_type);
1297
1298   if ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1299       || (mtype == DBUS_MESSAGE_TYPE_SIGNAL))
1300     {
1301       path = args[3];
1302       interface = args[4];
1303       member = args[5];
1304       if (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1305         handler = args[6];
1306       count = (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL) ? 7 : 6;
1307     }
1308   else /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR  */
1309     {
1310       serial = xd_extract_unsigned (args[3], TYPE_MAXIMUM (dbus_uint32_t));
1311       count = 4;
1312     }
1313
1314   /* Check parameters.  */
1315   XD_DBUS_VALIDATE_BUS_ADDRESS (bus);
1316   XD_DBUS_VALIDATE_BUS_NAME (service);
1317   if (nargs < count)
1318     xsignal2 (Qwrong_number_of_arguments,
1319               Qdbus_message_internal,
1320               make_number (nargs));
1321
1322   if ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1323       || (mtype == DBUS_MESSAGE_TYPE_SIGNAL))
1324     {
1325       XD_DBUS_VALIDATE_PATH (path);
1326       XD_DBUS_VALIDATE_INTERFACE (interface);
1327       XD_DBUS_VALIDATE_MEMBER (member);
1328       if (!NILP (handler) && (!FUNCTIONP (handler)))
1329         wrong_type_argument (Qinvalid_function, handler);
1330     }
1331
1332   /* Protect Lisp variables.  */
1333   GCPRO6 (bus, service, path, interface, member, handler);
1334
1335   /* Trace parameters.  */
1336   switch (mtype)
1337     {
1338     case DBUS_MESSAGE_TYPE_METHOD_CALL:
1339       XD_DEBUG_MESSAGE ("%s %s %s %s %s %s %s",
1340                         XD_MESSAGE_TYPE_TO_STRING (mtype),
1341                         XD_OBJECT_TO_STRING (bus),
1342                         XD_OBJECT_TO_STRING (service),
1343                         XD_OBJECT_TO_STRING (path),
1344                         XD_OBJECT_TO_STRING (interface),
1345                         XD_OBJECT_TO_STRING (member),
1346                         XD_OBJECT_TO_STRING (handler));
1347       break;
1348     case DBUS_MESSAGE_TYPE_SIGNAL:
1349       XD_DEBUG_MESSAGE ("%s %s %s %s %s %s",
1350                         XD_MESSAGE_TYPE_TO_STRING (mtype),
1351                         XD_OBJECT_TO_STRING (bus),
1352                         XD_OBJECT_TO_STRING (service),
1353                         XD_OBJECT_TO_STRING (path),
1354                         XD_OBJECT_TO_STRING (interface),
1355                         XD_OBJECT_TO_STRING (member));
1356       break;
1357     default: /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR  */
1358       ui_serial = serial;
1359       XD_DEBUG_MESSAGE ("%s %s %s %u",
1360                         XD_MESSAGE_TYPE_TO_STRING (mtype),
1361                         XD_OBJECT_TO_STRING (bus),
1362                         XD_OBJECT_TO_STRING (service),
1363                         ui_serial);
1364     }
1365
1366   /* Retrieve bus address.  */
1367   connection = xd_get_connection_address (bus);
1368
1369   /* Create the D-Bus message.  */
1370   dmessage = dbus_message_new (mtype);
1371   if (dmessage == NULL)
1372     {
1373       UNGCPRO;
1374       XD_SIGNAL1 (build_string ("Unable to create a new message"));
1375     }
1376
1377   if (STRINGP (service))
1378     {
1379       if (mtype != DBUS_MESSAGE_TYPE_SIGNAL)
1380         /* Set destination.  */
1381         {
1382           if (!dbus_message_set_destination (dmessage, SSDATA (service)))
1383             {
1384               UNGCPRO;
1385               XD_SIGNAL2 (build_string ("Unable to set the destination"),
1386                           service);
1387             }
1388         }
1389
1390       else
1391         /* Set destination for unicast signals.  */
1392         {
1393           Lisp_Object uname;
1394
1395           /* If it is the same unique name as we are registered at the
1396              bus or an unknown name, we regard it as broadcast message
1397              due to backward compatibility.  */
1398           if (dbus_bus_name_has_owner (connection, SSDATA (service), NULL))
1399             uname = call2 (intern ("dbus-get-name-owner"), bus, service);
1400           else
1401             uname = Qnil;
1402
1403           if (STRINGP (uname)
1404               && (strcmp (dbus_bus_get_unique_name (connection), SSDATA (uname))
1405                   != 0)
1406               && (!dbus_message_set_destination (dmessage, SSDATA (service))))
1407             {
1408               UNGCPRO;
1409               XD_SIGNAL2 (build_string ("Unable to set signal destination"),
1410                           service);
1411             }
1412         }
1413     }
1414
1415   /* Set message parameters.  */
1416   if ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1417       || (mtype == DBUS_MESSAGE_TYPE_SIGNAL))
1418     {
1419       if ((!dbus_message_set_path (dmessage, SSDATA (path)))
1420           || (!dbus_message_set_interface (dmessage, SSDATA (interface)))
1421           || (!dbus_message_set_member (dmessage, SSDATA (member))))
1422         {
1423           UNGCPRO;
1424           XD_SIGNAL1 (build_string ("Unable to set the message parameter"));
1425         }
1426     }
1427
1428   else /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR  */
1429     {
1430       if (!dbus_message_set_reply_serial (dmessage, serial))
1431         {
1432           UNGCPRO;
1433           XD_SIGNAL1 (build_string ("Unable to create a return message"));
1434         }
1435
1436       if ((mtype == DBUS_MESSAGE_TYPE_ERROR)
1437           && (!dbus_message_set_error_name (dmessage, DBUS_ERROR_FAILED)))
1438         {
1439           UNGCPRO;
1440           XD_SIGNAL1 (build_string ("Unable to create a error message"));
1441         }
1442     }
1443
1444   /* Check for timeout parameter.  */
1445   if ((count+2 <= nargs) && (EQ ((args[count]), QCdbus_timeout)))
1446     {
1447       CHECK_NATNUM (args[count+1]);
1448       timeout = min (XFASTINT (args[count+1]), INT_MAX);
1449       count = count+2;
1450     }
1451
1452   /* Initialize parameter list of message.  */
1453   dbus_message_iter_init_append (dmessage, &iter);
1454
1455   /* Append parameters to the message.  */
1456   for (; count < nargs; ++count)
1457     {
1458       dtype = XD_OBJECT_TO_DBUS_TYPE (args[count]);
1459       if (XD_DBUS_TYPE_P (args[count]))
1460         {
1461           XD_DEBUG_VALID_LISP_OBJECT_P (args[count]);
1462           XD_DEBUG_VALID_LISP_OBJECT_P (args[count+1]);
1463           XD_DEBUG_MESSAGE ("Parameter%"pD"d %s %s", count - 4,
1464                             XD_OBJECT_TO_STRING (args[count]),
1465                             XD_OBJECT_TO_STRING (args[count+1]));
1466           ++count;
1467         }
1468       else
1469         {
1470           XD_DEBUG_VALID_LISP_OBJECT_P (args[count]);
1471           XD_DEBUG_MESSAGE ("Parameter%"pD"d %s", count - 4,
1472                             XD_OBJECT_TO_STRING (args[count]));
1473         }
1474
1475       /* Check for valid signature.  We use DBUS_TYPE_INVALID as
1476          indication that there is no parent type.  */
1477       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[count]);
1478
1479       xd_append_arg (dtype, args[count], &iter);
1480     }
1481
1482   if (!NILP (handler))
1483     {
1484       /* Send the message.  The message is just added to the outgoing
1485          message queue.  */
1486       if (!dbus_connection_send_with_reply (connection, dmessage,
1487                                             NULL, timeout))
1488         {
1489           UNGCPRO;
1490           XD_SIGNAL1 (build_string ("Cannot send message"));
1491         }
1492
1493       /* The result is the key in Vdbus_registered_objects_table.  */
1494       serial = dbus_message_get_serial (dmessage);
1495       result = list3 (QCdbus_registered_serial,
1496                       bus, make_fixnum_or_float (serial));
1497
1498       /* Create a hash table entry.  */
1499       Fputhash (result, handler, Vdbus_registered_objects_table);
1500     }
1501   else
1502     {
1503       /* Send the message.  The message is just added to the outgoing
1504          message queue.  */
1505       if (!dbus_connection_send (connection, dmessage, NULL))
1506         {
1507           UNGCPRO;
1508           XD_SIGNAL1 (build_string ("Cannot send message"));
1509         }
1510
1511       result = Qnil;
1512     }
1513
1514   XD_DEBUG_MESSAGE ("Message sent: %s", XD_OBJECT_TO_STRING (result));
1515
1516   /* Cleanup.  */
1517   dbus_message_unref (dmessage);
1518
1519   /* Return the result.  */
1520   RETURN_UNGCPRO (result);
1521 }
1522
1523 /* Read one queued incoming message of the D-Bus BUS.
1524    BUS is either a Lisp symbol, :system or :session, or a string denoting
1525    the bus address.  */
1526 static void
1527 xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
1528 {
1529   Lisp_Object args, key, value;
1530   struct gcpro gcpro1;
1531   struct input_event event;
1532   DBusMessage *dmessage;
1533   DBusMessageIter iter;
1534   int dtype;
1535   int mtype;
1536   dbus_uint32_t serial;
1537   unsigned int ui_serial;
1538   const char *uname, *path, *interface, *member;
1539
1540   dmessage = dbus_connection_pop_message (connection);
1541
1542   /* Return if there is no queued message.  */
1543   if (dmessage == NULL)
1544     return;
1545
1546   /* Collect the parameters.  */
1547   args = Qnil;
1548   GCPRO1 (args);
1549
1550   /* Loop over the resulting parameters.  Construct a list.  */
1551   if (dbus_message_iter_init (dmessage, &iter))
1552     {
1553       while ((dtype = dbus_message_iter_get_arg_type (&iter))
1554              != DBUS_TYPE_INVALID)
1555         {
1556           args = Fcons (xd_retrieve_arg (dtype, &iter), args);
1557           dbus_message_iter_next (&iter);
1558         }
1559       /* The arguments are stored in reverse order.  Reorder them.  */
1560       args = Fnreverse (args);
1561     }
1562
1563   /* Read message type, message serial, unique name, object path,
1564      interface and member from the message.  */
1565   mtype = dbus_message_get_type (dmessage);
1566   ui_serial = serial =
1567     ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1568      || (mtype == DBUS_MESSAGE_TYPE_ERROR))
1569     ? dbus_message_get_reply_serial (dmessage)
1570     : dbus_message_get_serial (dmessage);
1571   uname = dbus_message_get_sender (dmessage);
1572   path = dbus_message_get_path (dmessage);
1573   interface = dbus_message_get_interface (dmessage);
1574   member = dbus_message_get_member (dmessage);
1575
1576   XD_DEBUG_MESSAGE ("Event received: %s %u %s %s %s %s %s",
1577                     XD_MESSAGE_TYPE_TO_STRING (mtype),
1578                     ui_serial, uname, path, interface, member,
1579                     XD_OBJECT_TO_STRING (args));
1580
1581   if (mtype == DBUS_MESSAGE_TYPE_INVALID)
1582     goto cleanup;
1583
1584   else if ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1585            || (mtype == DBUS_MESSAGE_TYPE_ERROR))
1586     {
1587       /* Search for a registered function of the message.  */
1588       key = list3 (QCdbus_registered_serial, bus,
1589                    make_fixnum_or_float (serial));
1590       value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1591
1592       /* There shall be exactly one entry.  Construct an event.  */
1593       if (NILP (value))
1594         goto cleanup;
1595
1596       /* Remove the entry.  */
1597       Fremhash (key, Vdbus_registered_objects_table);
1598
1599       /* Construct an event.  */
1600       EVENT_INIT (event);
1601       event.kind = DBUS_EVENT;
1602       event.frame_or_window = Qnil;
1603       event.arg = Fcons (value, args);
1604     }
1605
1606   else /* DBUS_MESSAGE_TYPE_METHOD_CALL, DBUS_MESSAGE_TYPE_SIGNAL.  */
1607     {
1608       /* Vdbus_registered_objects_table requires non-nil interface and
1609          member.  */
1610       if ((interface == NULL) || (member == NULL))
1611         goto cleanup;
1612
1613       /* Search for a registered function of the message.  */
1614       key = list4 ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1615                    ? QCdbus_registered_method
1616                    : QCdbus_registered_signal,
1617                    bus, build_string (interface), build_string (member));
1618       value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1619
1620       /* Loop over the registered functions.  Construct an event.  */
1621       while (!NILP (value))
1622         {
1623           key = CAR_SAFE (value);
1624           /* key has the structure (UNAME SERVICE PATH HANDLER).  */
1625           if (((uname == NULL)
1626                || (NILP (CAR_SAFE (key)))
1627                || (strcmp (uname, SSDATA (CAR_SAFE (key))) == 0))
1628               && ((path == NULL)
1629                   || (NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1630                   || (strcmp (path,
1631                               SSDATA (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1632                       == 0))
1633               && (!NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))))))
1634             {
1635               EVENT_INIT (event);
1636               event.kind = DBUS_EVENT;
1637               event.frame_or_window = Qnil;
1638               event.arg
1639                 = Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))), args);
1640               break;
1641             }
1642           value = CDR_SAFE (value);
1643         }
1644
1645       if (NILP (value))
1646         goto cleanup;
1647     }
1648
1649   /* Add type, serial, uname, path, interface and member to the event.  */
1650   event.arg = Fcons ((member == NULL ? Qnil : build_string (member)),
1651                      event.arg);
1652   event.arg = Fcons ((interface == NULL ? Qnil : build_string (interface)),
1653                      event.arg);
1654   event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
1655                      event.arg);
1656   event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
1657                      event.arg);
1658   event.arg = Fcons (make_fixnum_or_float (serial), event.arg);
1659   event.arg = Fcons (make_number (mtype), event.arg);
1660
1661   /* Add the bus symbol to the event.  */
1662   event.arg = Fcons (bus, event.arg);
1663
1664   /* Store it into the input event queue.  */
1665   kbd_buffer_store_event (&event);
1666
1667   XD_DEBUG_MESSAGE ("Event stored: %s", XD_OBJECT_TO_STRING (event.arg));
1668
1669   /* Cleanup.  */
1670  cleanup:
1671   dbus_message_unref (dmessage);
1672
1673   UNGCPRO;
1674 }
1675
1676 /* Read queued incoming messages of the D-Bus BUS.
1677    BUS is either a Lisp symbol, :system or :session, or a string denoting
1678    the bus address.  */
1679 static Lisp_Object
1680 xd_read_message (Lisp_Object bus)
1681 {
1682   /* Retrieve bus address.  */
1683   DBusConnection *connection = xd_get_connection_address (bus);
1684
1685   /* Non blocking read of the next available message.  */
1686   dbus_connection_read_write (connection, 0);
1687
1688   while (dbus_connection_get_dispatch_status (connection)
1689          != DBUS_DISPATCH_COMPLETE)
1690     xd_read_message_1 (connection, bus);
1691   return Qnil;
1692 }
1693
1694 /* Callback called when something is ready to read or write.  */
1695 static void
1696 xd_read_queued_messages (int fd, void *data)
1697 {
1698   Lisp_Object busp = xd_registered_buses;
1699   Lisp_Object bus = Qnil;
1700   Lisp_Object key;
1701
1702   /* Find bus related to fd.  */
1703   if (data != NULL)
1704     while (!NILP (busp))
1705       {
1706         key = CAR_SAFE (CAR_SAFE (busp));
1707         if ((SYMBOLP (key) && XSYMBOL (key) == data)
1708             || (STRINGP (key) && XSTRING (key) == data))
1709           bus = key;
1710         busp = CDR_SAFE (busp);
1711       }
1712
1713   if (NILP (bus))
1714     return;
1715
1716   /* We ignore all Lisp errors during the call.  */
1717   xd_in_read_queued_messages = 1;
1718   internal_catch (Qdbus_error, xd_read_message, bus);
1719   xd_in_read_queued_messages = 0;
1720 }
1721
1722 \f
1723 void
1724 syms_of_dbusbind (void)
1725 {
1726
1727   DEFSYM (Qdbus_init_bus, "dbus-init-bus");
1728   defsubr (&Sdbus_init_bus);
1729
1730   DEFSYM (Qdbus_get_unique_name, "dbus-get-unique-name");
1731   defsubr (&Sdbus_get_unique_name);
1732
1733   DEFSYM (Qdbus_message_internal, "dbus-message-internal");
1734   defsubr (&Sdbus_message_internal);
1735
1736   DEFSYM (Qdbus_error, "dbus-error");
1737   Fput (Qdbus_error, Qerror_conditions,
1738         list2 (Qdbus_error, Qerror));
1739   Fput (Qdbus_error, Qerror_message,
1740         build_pure_c_string ("D-Bus error"));
1741
1742   DEFSYM (QCdbus_system_bus, ":system");
1743   DEFSYM (QCdbus_session_bus, ":session");
1744   DEFSYM (QCdbus_timeout, ":timeout");
1745   DEFSYM (QCdbus_type_byte, ":byte");
1746   DEFSYM (QCdbus_type_boolean, ":boolean");
1747   DEFSYM (QCdbus_type_int16, ":int16");
1748   DEFSYM (QCdbus_type_uint16, ":uint16");
1749   DEFSYM (QCdbus_type_int32, ":int32");
1750   DEFSYM (QCdbus_type_uint32, ":uint32");
1751   DEFSYM (QCdbus_type_int64, ":int64");
1752   DEFSYM (QCdbus_type_uint64, ":uint64");
1753   DEFSYM (QCdbus_type_double, ":double");
1754   DEFSYM (QCdbus_type_string, ":string");
1755   DEFSYM (QCdbus_type_object_path, ":object-path");
1756   DEFSYM (QCdbus_type_signature, ":signature");
1757 #ifdef DBUS_TYPE_UNIX_FD
1758   DEFSYM (QCdbus_type_unix_fd, ":unix-fd");
1759 #endif
1760   DEFSYM (QCdbus_type_array, ":array");
1761   DEFSYM (QCdbus_type_variant, ":variant");
1762   DEFSYM (QCdbus_type_struct, ":struct");
1763   DEFSYM (QCdbus_type_dict_entry, ":dict-entry");
1764   DEFSYM (QCdbus_registered_serial, ":serial");
1765   DEFSYM (QCdbus_registered_method, ":method");
1766   DEFSYM (QCdbus_registered_signal, ":signal");
1767
1768   DEFVAR_LISP ("dbus-compiled-version",
1769                Vdbus_compiled_version,
1770     doc: /* The version of D-Bus Emacs is compiled against.  */);
1771 #ifdef DBUS_VERSION_STRING
1772   Vdbus_compiled_version = build_pure_c_string (DBUS_VERSION_STRING);
1773 #else
1774   Vdbus_compiled_version = Qnil;
1775 #endif
1776
1777   DEFVAR_LISP ("dbus-runtime-version",
1778                Vdbus_runtime_version,
1779     doc: /* The version of D-Bus Emacs runs with.  */);
1780   {
1781 #ifdef DBUS_VERSION
1782     int major, minor, micro;
1783     char s[sizeof ".." + 3 * INT_STRLEN_BOUND (int)];
1784     dbus_get_version (&major, &minor, &micro);
1785     Vdbus_runtime_version
1786       = make_formatted_string (s, "%d.%d.%d", major, minor, micro);
1787 #else
1788     Vdbus_runtime_version = Qnil;
1789 #endif
1790   }
1791
1792   DEFVAR_LISP ("dbus-message-type-invalid",
1793                Vdbus_message_type_invalid,
1794     doc: /* This value is never a valid message type.  */);
1795   Vdbus_message_type_invalid = make_number (DBUS_MESSAGE_TYPE_INVALID);
1796
1797   DEFVAR_LISP ("dbus-message-type-method-call",
1798                Vdbus_message_type_method_call,
1799     doc: /* Message type of a method call message.  */);
1800   Vdbus_message_type_method_call = make_number (DBUS_MESSAGE_TYPE_METHOD_CALL);
1801
1802   DEFVAR_LISP ("dbus-message-type-method-return",
1803                Vdbus_message_type_method_return,
1804     doc: /* Message type of a method return message.  */);
1805   Vdbus_message_type_method_return
1806     = make_number (DBUS_MESSAGE_TYPE_METHOD_RETURN);
1807
1808   DEFVAR_LISP ("dbus-message-type-error",
1809                Vdbus_message_type_error,
1810     doc: /* Message type of an error reply message.  */);
1811   Vdbus_message_type_error = make_number (DBUS_MESSAGE_TYPE_ERROR);
1812
1813   DEFVAR_LISP ("dbus-message-type-signal",
1814                Vdbus_message_type_signal,
1815     doc: /* Message type of a signal message.  */);
1816   Vdbus_message_type_signal = make_number (DBUS_MESSAGE_TYPE_SIGNAL);
1817
1818   DEFVAR_LISP ("dbus-registered-objects-table",
1819                Vdbus_registered_objects_table,
1820     doc: /* Hash table of registered functions for D-Bus.
1821
1822 There are two different uses of the hash table: for accessing
1823 registered interfaces properties, targeted by signals or method calls,
1824 and for calling handlers in case of non-blocking method call returns.
1825
1826 In the first case, the key in the hash table is the list (TYPE BUS
1827 INTERFACE MEMBER).  TYPE is one of the Lisp symbols `:method',
1828 `:signal' or `:property'.  BUS is either a Lisp symbol, `:system' or
1829 `:session', or a string denoting the bus address.  INTERFACE is a
1830 string which denotes a D-Bus interface, and MEMBER, also a string, is
1831 either a method, a signal or a property INTERFACE is offering.  All
1832 arguments but BUS must not be nil.
1833
1834 The value in the hash table is a list of quadruple lists \((UNAME
1835 SERVICE PATH OBJECT [RULE]) ...).  SERVICE is the service name as
1836 registered, UNAME is the corresponding unique name.  In case of
1837 registered methods and properties, UNAME is nil.  PATH is the object
1838 path of the sending object.  All of them can be nil, which means a
1839 wildcard then.  OBJECT is either the handler to be called when a D-Bus
1840 message, which matches the key criteria, arrives (TYPE `:method' and
1841 `:signal'), or a cons cell containing the value of the property (TYPE
1842 `:property').
1843
1844 For entries of type `:signal', there is also a fifth element RULE,
1845 which keeps the match string the signal is registered with.
1846
1847 In the second case, the key in the hash table is the list (:serial BUS
1848 SERIAL).  BUS is either a Lisp symbol, `:system' or `:session', or a
1849 string denoting the bus address.  SERIAL is the serial number of the
1850 non-blocking method call, a reply is expected.  Both arguments must
1851 not be nil.  The value in the hash table is HANDLER, the function to
1852 be called when the D-Bus reply message arrives.  */);
1853   {
1854     Lisp_Object args[2];
1855     args[0] = QCtest;
1856     args[1] = Qequal;
1857     Vdbus_registered_objects_table = Fmake_hash_table (2, args);
1858   }
1859
1860   DEFVAR_LISP ("dbus-debug", Vdbus_debug,
1861     doc: /* If non-nil, debug messages of D-Bus bindings are raised.  */);
1862 #ifdef DBUS_DEBUG
1863   Vdbus_debug = Qt;
1864   /* We can also set environment variable DBUS_VERBOSE=1 in order to
1865      see more traces.  This requires libdbus-1 to be configured with
1866      --enable-verbose-mode.  */
1867 #else
1868   Vdbus_debug = Qnil;
1869 #endif
1870
1871   /* Initialize internal objects.  */
1872   xd_registered_buses = Qnil;
1873   staticpro (&xd_registered_buses);
1874
1875   Fprovide (intern_c_string ("dbusbind"), Qnil);
1876
1877 }
1878
1879 #endif /* HAVE_DBUS */