src/dbusbind.c

   1 /* Elisp bindings for D-Bus.
   2    Copyright (C) 2007-2014 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                 lispstpcpy (signature, 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 /* Convert a Lisp D-Bus object to a pointer.  */
 973 static DBusConnection*
 974 xd_lisp_dbus_to_dbus (Lisp_Object bus)
 975 {
 976   return (DBusConnection *) (intptr_t) XFASTINT (bus);
 977 }
 978
 979 /* Return D-Bus connection address.  BUS is either a Lisp symbol,
 980    :system or :session, or a string denoting the bus address.  */
 981 static DBusConnection *
 982 xd_get_connection_address (Lisp_Object bus)
 983 {
 984   DBusConnection *connection;
 985   Lisp_Object val;
 986
 987   val = CDR_SAFE (Fassoc (bus, xd_registered_buses));
 988   if (NILP (val))
 989     XD_SIGNAL2 (build_string ("No connection to bus"), bus);
 990   else
 991     connection = xd_lisp_dbus_to_dbus (val);
 992
 993   if (!dbus_connection_get_is_connected (connection))
 994     XD_SIGNAL2 (build_string ("No connection to bus"), bus);
 995
 996   return connection;
 997 }
 998
 999 /* Return the file descriptor for WATCH, -1 if not found.  */
1000 static int
1001 xd_find_watch_fd (DBusWatch *watch)
1002 {
1003 #if HAVE_DBUS_WATCH_GET_UNIX_FD
1004   /* TODO: Reverse these on w32, which prefers the opposite.  */
1005   int fd = dbus_watch_get_unix_fd (watch);
1006   if (fd == -1)
1007     fd = dbus_watch_get_socket (watch);
1008 #else
1009   int fd = dbus_watch_get_fd (watch);
1010 #endif
1011   return fd;
1012 }
1013
1014 /* Prototype.  */
1015 static void xd_read_queued_messages (int fd, void *data);
1016
1017 /* Start monitoring WATCH for possible I/O.  */
1018 static dbus_bool_t
1019 xd_add_watch (DBusWatch *watch, void *data)
1020 {
1021   unsigned int flags = dbus_watch_get_flags (watch);
1022   int fd = xd_find_watch_fd (watch);
1023
1024   XD_DEBUG_MESSAGE ("fd %d, write %d, enabled %d",
1025                     fd, flags & DBUS_WATCH_WRITABLE,
1026                     dbus_watch_get_enabled (watch));
1027
1028   if (fd == -1)
1029     return FALSE;
1030
1031   if (dbus_watch_get_enabled (watch))
1032     {
1033       if (flags & DBUS_WATCH_WRITABLE)
1034         add_write_fd (fd, xd_read_queued_messages, data);
1035       if (flags & DBUS_WATCH_READABLE)
1036         add_read_fd (fd, xd_read_queued_messages, data);
1037     }
1038   return TRUE;
1039 }
1040
1041 /* Stop monitoring WATCH for possible I/O.
1042    DATA is the used bus, either a string or QCdbus_system_bus or
1043    QCdbus_session_bus.  */
1044 static void
1045 xd_remove_watch (DBusWatch *watch, void *data)
1046 {
1047   unsigned int flags = dbus_watch_get_flags (watch);
1048   int fd = xd_find_watch_fd (watch);
1049
1050   XD_DEBUG_MESSAGE ("fd %d", fd);
1051
1052   if (fd == -1)
1053     return;
1054
1055   /* Unset session environment.  */
1056 #if 0
1057   /* This is buggy, since unsetenv is not thread-safe.  */
1058   if (XSYMBOL (QCdbus_session_bus) == data)
1059     {
1060       XD_DEBUG_MESSAGE ("unsetenv DBUS_SESSION_BUS_ADDRESS");
1061       unsetenv ("DBUS_SESSION_BUS_ADDRESS");
1062     }
1063 #endif
1064
1065   if (flags & DBUS_WATCH_WRITABLE)
1066     delete_write_fd (fd);
1067   if (flags & DBUS_WATCH_READABLE)
1068     delete_read_fd (fd);
1069 }
1070
1071 /* Toggle monitoring WATCH for possible I/O.  */
1072 static void
1073 xd_toggle_watch (DBusWatch *watch, void *data)
1074 {
1075   if (dbus_watch_get_enabled (watch))
1076     xd_add_watch (watch, data);
1077   else
1078     xd_remove_watch (watch, data);
1079 }
1080
1081 /* Close connection to D-Bus BUS.  */
1082 static void
1083 xd_close_bus (Lisp_Object bus)
1084 {
1085   DBusConnection *connection;
1086   Lisp_Object val;
1087   Lisp_Object busobj;
1088
1089   /* Check whether we are connected.  */
1090   val = Fassoc (bus, xd_registered_buses);
1091   if (NILP (val))
1092     return;
1093
1094   busobj = CDR_SAFE (val);
1095   if (NILP (busobj)) {
1096     xd_registered_buses = Fdelete (val, xd_registered_buses);
1097     return;
1098   }
1099
1100   /* Retrieve bus address.  */
1101   connection = xd_lisp_dbus_to_dbus (busobj);
1102
1103   if (xd_get_connection_references (connection) == 1)
1104     {
1105       /* Close connection, if there isn't another shared application.  */
1106       XD_DEBUG_MESSAGE ("Close connection to bus %s",
1107                         XD_OBJECT_TO_STRING (bus));
1108       dbus_connection_close (connection);
1109
1110       xd_registered_buses = Fdelete (val, xd_registered_buses);
1111     }
1112
1113   else
1114     /* Decrement reference count.  */
1115     dbus_connection_unref (connection);
1116
1117   /* Return.  */
1118   return;
1119 }
1120
1121 DEFUN ("dbus--init-bus", Fdbus__init_bus, Sdbus__init_bus, 1, 2, 0,
1122        doc: /* Establish the connection to D-Bus BUS.
1123
1124 This function is dbus internal.  You almost certainly want to use
1125 `dbus-init-bus'.
1126
1127 BUS can be either the symbol `:system' or the symbol `:session', or it
1128 can be a string denoting the address of the corresponding bus.  For
1129 the system and session buses, this function is called when loading
1130 `dbus.el', there is no need to call it again.
1131
1132 The function returns a number, which counts the connections this Emacs
1133 session has established to the BUS under the same unique name (see
1134 `dbus-get-unique-name').  It depends on the libraries Emacs is linked
1135 with, and on the environment Emacs is running.  For example, if Emacs
1136 is linked with the gtk toolkit, and it runs in a GTK-aware environment
1137 like Gnome, another connection might already be established.
1138
1139 When PRIVATE is non-nil, a new connection is established instead of
1140 reusing an existing one.  It results in a new unique name at the bus.
1141 This can be used, if it is necessary to distinguish from another
1142 connection used in the same Emacs process, like the one established by
1143 GTK+.  It should be used with care for at least the `:system' and
1144 `:session' buses, because other Emacs Lisp packages might already use
1145 this connection to those buses.  */)
1146   (Lisp_Object bus, Lisp_Object private)
1147 {
1148   DBusConnection *connection;
1149   DBusError derror;
1150   Lisp_Object val;
1151   ptrdiff_t refcount;
1152
1153   /* Check parameter.  */
1154   XD_DBUS_VALIDATE_BUS_ADDRESS (bus);
1155
1156   /* Close bus if it is already open.  */
1157   xd_close_bus (bus);
1158
1159   /* Check, whether we are still connected.  */
1160   val = Fassoc (bus, xd_registered_buses);
1161   if (!NILP (val))
1162     {
1163       connection = xd_get_connection_address (bus);
1164       dbus_connection_ref (connection);
1165     }
1166
1167   else
1168     {
1169       /* Initialize.  */
1170       dbus_error_init (&derror);
1171
1172       /* Open the connection.  */
1173       if (STRINGP (bus))
1174         if (NILP (private))
1175           connection = dbus_connection_open (SSDATA (bus), &derror);
1176         else
1177           connection = dbus_connection_open_private (SSDATA (bus), &derror);
1178
1179       else
1180         if (NILP (private))
1181           connection = dbus_bus_get (EQ (bus, QCdbus_system_bus)
1182                                      ? DBUS_BUS_SYSTEM : DBUS_BUS_SESSION,
1183                                      &derror);
1184         else
1185           connection = dbus_bus_get_private (EQ (bus, QCdbus_system_bus)
1186                                              ? DBUS_BUS_SYSTEM : DBUS_BUS_SESSION,
1187                                              &derror);
1188
1189       if (dbus_error_is_set (&derror))
1190         XD_ERROR (derror);
1191
1192       if (connection == NULL)
1193         XD_SIGNAL2 (build_string ("No connection to bus"), bus);
1194
1195       /* If it is not the system or session bus, we must register
1196          ourselves.  Otherwise, we have called dbus_bus_get, which has
1197          configured us to exit if the connection closes - we undo this
1198          setting.  */
1199       if (STRINGP (bus))
1200         dbus_bus_register (connection, &derror);
1201       else
1202         dbus_connection_set_exit_on_disconnect (connection, FALSE);
1203
1204       if (dbus_error_is_set (&derror))
1205         XD_ERROR (derror);
1206
1207       /* Add the watch functions.  We pass also the bus as data, in
1208          order to distinguish between the buses in xd_remove_watch.  */
1209       if (!dbus_connection_set_watch_functions (connection,
1210                                                 xd_add_watch,
1211                                                 xd_remove_watch,
1212                                                 xd_toggle_watch,
1213                                                 SYMBOLP (bus)
1214                                                 ? (void *) XSYMBOL (bus)
1215                                                 : (void *) XSTRING (bus),
1216                                                 NULL))
1217         XD_SIGNAL1 (build_string ("Cannot add watch functions"));
1218
1219       /* Add bus to list of registered buses.  */
1220       XSETFASTINT (val, (intptr_t) connection);
1221       xd_registered_buses = Fcons (Fcons (bus, val), xd_registered_buses);
1222
1223       /* Cleanup.  */
1224       dbus_error_free (&derror);
1225     }
1226
1227   /* Return reference counter.  */
1228   refcount = xd_get_connection_references (connection);
1229   XD_DEBUG_MESSAGE ("Bus %s, Reference counter %"pD"d",
1230                     XD_OBJECT_TO_STRING (bus), refcount);
1231   return make_number (refcount);
1232 }
1233
1234 DEFUN ("dbus-get-unique-name", Fdbus_get_unique_name, Sdbus_get_unique_name,
1235        1, 1, 0,
1236        doc: /* Return the unique name of Emacs registered at D-Bus BUS.  */)
1237   (Lisp_Object bus)
1238 {
1239   DBusConnection *connection;
1240   const char *name;
1241
1242   /* Check parameter.  */
1243   XD_DBUS_VALIDATE_BUS_ADDRESS (bus);
1244
1245   /* Retrieve bus address.  */
1246   connection = xd_get_connection_address (bus);
1247
1248   /* Request the name.  */
1249   name = dbus_bus_get_unique_name (connection);
1250   if (name == NULL)
1251     XD_SIGNAL1 (build_string ("No unique name available"));
1252
1253   /* Return.  */
1254   return build_string (name);
1255 }
1256
1257 DEFUN ("dbus-message-internal", Fdbus_message_internal, Sdbus_message_internal,
1258        4, MANY, 0,
1259        doc: /* Send a D-Bus message.
1260 This is an internal function, it shall not be used outside dbus.el.
1261
1262 The following usages are expected:
1263
1264 `dbus-call-method', `dbus-call-method-asynchronously':
1265   \(dbus-message-internal
1266     dbus-message-type-method-call BUS SERVICE PATH INTERFACE METHOD HANDLER
1267     &optional :timeout TIMEOUT &rest ARGS)
1268
1269 `dbus-send-signal':
1270   \(dbus-message-internal
1271     dbus-message-type-signal BUS SERVICE PATH INTERFACE SIGNAL &rest ARGS)
1272
1273 `dbus-method-return-internal':
1274   \(dbus-message-internal
1275     dbus-message-type-method-return BUS SERVICE SERIAL &rest ARGS)
1276
1277 `dbus-method-error-internal':
1278   \(dbus-message-internal
1279     dbus-message-type-error BUS SERVICE SERIAL &rest ARGS)
1280
1281 usage: (dbus-message-internal &rest REST)  */)
1282   (ptrdiff_t nargs, Lisp_Object *args)
1283 {
1284   Lisp_Object message_type, bus, service, handler;
1285   Lisp_Object path = Qnil;
1286   Lisp_Object interface = Qnil;
1287   Lisp_Object member = Qnil;
1288   Lisp_Object result;
1289   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5, gcpro6;
1290   DBusConnection *connection;
1291   DBusMessage *dmessage;
1292   DBusMessageIter iter;
1293   int dtype;
1294   int mtype;
1295   dbus_uint32_t serial = 0;
1296   unsigned int ui_serial;
1297   int timeout = -1;
1298   ptrdiff_t count;
1299   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1300
1301   /* Initialize parameters.  */
1302   message_type = args[0];
1303   bus = args[1];
1304   service = args[2];
1305   handler = Qnil;
1306
1307   CHECK_NATNUM (message_type);
1308   if (! (DBUS_MESSAGE_TYPE_INVALID < XFASTINT (message_type)
1309          && XFASTINT (message_type) < DBUS_NUM_MESSAGE_TYPES))
1310     XD_SIGNAL2 (build_string ("Invalid message type"), message_type);
1311   mtype = XFASTINT (message_type);
1312
1313   if ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1314       || (mtype == DBUS_MESSAGE_TYPE_SIGNAL))
1315     {
1316       path = args[3];
1317       interface = args[4];
1318       member = args[5];
1319       if (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1320         handler = args[6];
1321       count = (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL) ? 7 : 6;
1322     }
1323   else /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR  */
1324     {
1325       serial = xd_extract_unsigned (args[3], TYPE_MAXIMUM (dbus_uint32_t));
1326       count = 4;
1327     }
1328
1329   /* Check parameters.  */
1330   XD_DBUS_VALIDATE_BUS_ADDRESS (bus);
1331   XD_DBUS_VALIDATE_BUS_NAME (service);
1332   if (nargs < count)
1333     xsignal2 (Qwrong_number_of_arguments,
1334               Qdbus_message_internal,
1335               make_number (nargs));
1336
1337   if ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1338       || (mtype == DBUS_MESSAGE_TYPE_SIGNAL))
1339     {
1340       XD_DBUS_VALIDATE_PATH (path);
1341       XD_DBUS_VALIDATE_INTERFACE (interface);
1342       XD_DBUS_VALIDATE_MEMBER (member);
1343       if (!NILP (handler) && (!FUNCTIONP (handler)))
1344         wrong_type_argument (Qinvalid_function, handler);
1345     }
1346
1347   /* Protect Lisp variables.  */
1348   GCPRO6 (bus, service, path, interface, member, handler);
1349
1350   /* Trace parameters.  */
1351   switch (mtype)
1352     {
1353     case DBUS_MESSAGE_TYPE_METHOD_CALL:
1354       XD_DEBUG_MESSAGE ("%s %s %s %s %s %s %s",
1355                         XD_MESSAGE_TYPE_TO_STRING (mtype),
1356                         XD_OBJECT_TO_STRING (bus),
1357                         XD_OBJECT_TO_STRING (service),
1358                         XD_OBJECT_TO_STRING (path),
1359                         XD_OBJECT_TO_STRING (interface),
1360                         XD_OBJECT_TO_STRING (member),
1361                         XD_OBJECT_TO_STRING (handler));
1362       break;
1363     case DBUS_MESSAGE_TYPE_SIGNAL:
1364       XD_DEBUG_MESSAGE ("%s %s %s %s %s %s",
1365                         XD_MESSAGE_TYPE_TO_STRING (mtype),
1366                         XD_OBJECT_TO_STRING (bus),
1367                         XD_OBJECT_TO_STRING (service),
1368                         XD_OBJECT_TO_STRING (path),
1369                         XD_OBJECT_TO_STRING (interface),
1370                         XD_OBJECT_TO_STRING (member));
1371       break;
1372     default: /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR  */
1373       ui_serial = serial;
1374       XD_DEBUG_MESSAGE ("%s %s %s %u",
1375                         XD_MESSAGE_TYPE_TO_STRING (mtype),
1376                         XD_OBJECT_TO_STRING (bus),
1377                         XD_OBJECT_TO_STRING (service),
1378                         ui_serial);
1379     }
1380
1381   /* Retrieve bus address.  */
1382   connection = xd_get_connection_address (bus);
1383
1384   /* Create the D-Bus message.  */
1385   dmessage = dbus_message_new (mtype);
1386   if (dmessage == NULL)
1387     {
1388       UNGCPRO;
1389       XD_SIGNAL1 (build_string ("Unable to create a new message"));
1390     }
1391
1392   if (STRINGP (service))
1393     {
1394       if (mtype != DBUS_MESSAGE_TYPE_SIGNAL)
1395         /* Set destination.  */
1396         {
1397           if (!dbus_message_set_destination (dmessage, SSDATA (service)))
1398             {
1399               UNGCPRO;
1400               XD_SIGNAL2 (build_string ("Unable to set the destination"),
1401                           service);
1402             }
1403         }
1404
1405       else
1406         /* Set destination for unicast signals.  */
1407         {
1408           Lisp_Object uname;
1409
1410           /* If it is the same unique name as we are registered at the
1411              bus or an unknown name, we regard it as broadcast message
1412              due to backward compatibility.  */
1413           if (dbus_bus_name_has_owner (connection, SSDATA (service), NULL))
1414             uname = call2 (intern ("dbus-get-name-owner"), bus, service);
1415           else
1416             uname = Qnil;
1417
1418           if (STRINGP (uname)
1419               && (strcmp (dbus_bus_get_unique_name (connection), SSDATA (uname))
1420                   != 0)
1421               && (!dbus_message_set_destination (dmessage, SSDATA (service))))
1422             {
1423               UNGCPRO;
1424               XD_SIGNAL2 (build_string ("Unable to set signal destination"),
1425                           service);
1426             }
1427         }
1428     }
1429
1430   /* Set message parameters.  */
1431   if ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1432       || (mtype == DBUS_MESSAGE_TYPE_SIGNAL))
1433     {
1434       if ((!dbus_message_set_path (dmessage, SSDATA (path)))
1435           || (!dbus_message_set_interface (dmessage, SSDATA (interface)))
1436           || (!dbus_message_set_member (dmessage, SSDATA (member))))
1437         {
1438           UNGCPRO;
1439           XD_SIGNAL1 (build_string ("Unable to set the message parameter"));
1440         }
1441     }
1442
1443   else /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR  */
1444     {
1445       if (!dbus_message_set_reply_serial (dmessage, serial))
1446         {
1447           UNGCPRO;
1448           XD_SIGNAL1 (build_string ("Unable to create a return message"));
1449         }
1450
1451       if ((mtype == DBUS_MESSAGE_TYPE_ERROR)
1452           && (!dbus_message_set_error_name (dmessage, DBUS_ERROR_FAILED)))
1453         {
1454           UNGCPRO;
1455           XD_SIGNAL1 (build_string ("Unable to create a error message"));
1456         }
1457     }
1458
1459   /* Check for timeout parameter.  */
1460   if ((count+2 <= nargs) && (EQ ((args[count]), QCdbus_timeout)))
1461     {
1462       CHECK_NATNUM (args[count+1]);
1463       timeout = min (XFASTINT (args[count+1]), INT_MAX);
1464       count = count+2;
1465     }
1466
1467   /* Initialize parameter list of message.  */
1468   dbus_message_iter_init_append (dmessage, &iter);
1469
1470   /* Append parameters to the message.  */
1471   for (; count < nargs; ++count)
1472     {
1473       dtype = XD_OBJECT_TO_DBUS_TYPE (args[count]);
1474       if (XD_DBUS_TYPE_P (args[count]))
1475         {
1476           XD_DEBUG_VALID_LISP_OBJECT_P (args[count]);
1477           XD_DEBUG_VALID_LISP_OBJECT_P (args[count+1]);
1478           XD_DEBUG_MESSAGE ("Parameter%"pD"d %s %s", count - 4,
1479                             XD_OBJECT_TO_STRING (args[count]),
1480                             XD_OBJECT_TO_STRING (args[count+1]));
1481           ++count;
1482         }
1483       else
1484         {
1485           XD_DEBUG_VALID_LISP_OBJECT_P (args[count]);
1486           XD_DEBUG_MESSAGE ("Parameter%"pD"d %s", count - 4,
1487                             XD_OBJECT_TO_STRING (args[count]));
1488         }
1489
1490       /* Check for valid signature.  We use DBUS_TYPE_INVALID as
1491          indication that there is no parent type.  */
1492       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[count]);
1493
1494       xd_append_arg (dtype, args[count], &iter);
1495     }
1496
1497   if (!NILP (handler))
1498     {
1499       /* Send the message.  The message is just added to the outgoing
1500          message queue.  */
1501       if (!dbus_connection_send_with_reply (connection, dmessage,
1502                                             NULL, timeout))
1503         {
1504           UNGCPRO;
1505           XD_SIGNAL1 (build_string ("Cannot send message"));
1506         }
1507
1508       /* The result is the key in Vdbus_registered_objects_table.  */
1509       serial = dbus_message_get_serial (dmessage);
1510       result = list3 (QCdbus_registered_serial,
1511                       bus, make_fixnum_or_float (serial));
1512
1513       /* Create a hash table entry.  */
1514       Fputhash (result, handler, Vdbus_registered_objects_table);
1515     }
1516   else
1517     {
1518       /* Send the message.  The message is just added to the outgoing
1519          message queue.  */
1520       if (!dbus_connection_send (connection, dmessage, NULL))
1521         {
1522           UNGCPRO;
1523           XD_SIGNAL1 (build_string ("Cannot send message"));
1524         }
1525
1526       result = Qnil;
1527     }
1528
1529   XD_DEBUG_MESSAGE ("Message sent: %s", XD_OBJECT_TO_STRING (result));
1530
1531   /* Cleanup.  */
1532   dbus_message_unref (dmessage);
1533
1534   /* Return the result.  */
1535   RETURN_UNGCPRO (result);
1536 }
1537
1538 /* Read one queued incoming message of the D-Bus BUS.
1539    BUS is either a Lisp symbol, :system or :session, or a string denoting
1540    the bus address.  */
1541 static void
1542 xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
1543 {
1544   Lisp_Object args, key, value;
1545   struct gcpro gcpro1;
1546   struct input_event event;
1547   DBusMessage *dmessage;
1548   DBusMessageIter iter;
1549   int dtype;
1550   int mtype;
1551   dbus_uint32_t serial;
1552   unsigned int ui_serial;
1553   const char *uname, *path, *interface, *member;
1554
1555   dmessage = dbus_connection_pop_message (connection);
1556
1557   /* Return if there is no queued message.  */
1558   if (dmessage == NULL)
1559     return;
1560
1561   /* Collect the parameters.  */
1562   args = Qnil;
1563   GCPRO1 (args);
1564
1565   /* Loop over the resulting parameters.  Construct a list.  */
1566   if (dbus_message_iter_init (dmessage, &iter))
1567     {
1568       while ((dtype = dbus_message_iter_get_arg_type (&iter))
1569              != DBUS_TYPE_INVALID)
1570         {
1571           args = Fcons (xd_retrieve_arg (dtype, &iter), args);
1572           dbus_message_iter_next (&iter);
1573         }
1574       /* The arguments are stored in reverse order.  Reorder them.  */
1575       args = Fnreverse (args);
1576     }
1577
1578   /* Read message type, message serial, unique name, object path,
1579      interface and member from the message.  */
1580   mtype = dbus_message_get_type (dmessage);
1581   ui_serial = serial =
1582     ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1583      || (mtype == DBUS_MESSAGE_TYPE_ERROR))
1584     ? dbus_message_get_reply_serial (dmessage)
1585     : dbus_message_get_serial (dmessage);
1586   uname = dbus_message_get_sender (dmessage);
1587   path = dbus_message_get_path (dmessage);
1588   interface = dbus_message_get_interface (dmessage);
1589   member = dbus_message_get_member (dmessage);
1590
1591   XD_DEBUG_MESSAGE ("Event received: %s %u %s %s %s %s %s",
1592                     XD_MESSAGE_TYPE_TO_STRING (mtype),
1593                     ui_serial, uname, path, interface, member,
1594                     XD_OBJECT_TO_STRING (args));
1595
1596   if (mtype == DBUS_MESSAGE_TYPE_INVALID)
1597     goto cleanup;
1598
1599   else if ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1600            || (mtype == DBUS_MESSAGE_TYPE_ERROR))
1601     {
1602       /* Search for a registered function of the message.  */
1603       key = list3 (QCdbus_registered_serial, bus,
1604                    make_fixnum_or_float (serial));
1605       value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1606
1607       /* There shall be exactly one entry.  Construct an event.  */
1608       if (NILP (value))
1609         goto cleanup;
1610
1611       /* Remove the entry.  */
1612       Fremhash (key, Vdbus_registered_objects_table);
1613
1614       /* Construct an event.  */
1615       EVENT_INIT (event);
1616       event.kind = DBUS_EVENT;
1617       event.frame_or_window = Qnil;
1618       event.arg = Fcons (value, args);
1619     }
1620
1621   else /* DBUS_MESSAGE_TYPE_METHOD_CALL, DBUS_MESSAGE_TYPE_SIGNAL.  */
1622     {
1623       /* Vdbus_registered_objects_table requires non-nil interface and
1624          member.  */
1625       if ((interface == NULL) || (member == NULL))
1626         goto cleanup;
1627
1628       /* Search for a registered function of the message.  */
1629       key = list4 ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1630                    ? QCdbus_registered_method
1631                    : QCdbus_registered_signal,
1632                    bus, build_string (interface), build_string (member));
1633       value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1634
1635       /* Loop over the registered functions.  Construct an event.  */
1636       while (!NILP (value))
1637         {
1638           key = CAR_SAFE (value);
1639           /* key has the structure (UNAME SERVICE PATH HANDLER).  */
1640           if (((uname == NULL)
1641                || (NILP (CAR_SAFE (key)))
1642                || (strcmp (uname, SSDATA (CAR_SAFE (key))) == 0))
1643               && ((path == NULL)
1644                   || (NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1645                   || (strcmp (path,
1646                               SSDATA (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1647                       == 0))
1648               && (!NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))))))
1649             {
1650               EVENT_INIT (event);
1651               event.kind = DBUS_EVENT;
1652               event.frame_or_window = Qnil;
1653               event.arg
1654                 = Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))), args);
1655               break;
1656             }
1657           value = CDR_SAFE (value);
1658         }
1659
1660       if (NILP (value))
1661         goto cleanup;
1662     }
1663
1664   /* Add type, serial, uname, path, interface and member to the event.  */
1665   event.arg = Fcons ((member == NULL ? Qnil : build_string (member)),
1666                      event.arg);
1667   event.arg = Fcons ((interface == NULL ? Qnil : build_string (interface)),
1668                      event.arg);
1669   event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
1670                      event.arg);
1671   event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
1672                      event.arg);
1673   event.arg = Fcons (make_fixnum_or_float (serial), event.arg);
1674   event.arg = Fcons (make_number (mtype), event.arg);
1675
1676   /* Add the bus symbol to the event.  */
1677   event.arg = Fcons (bus, event.arg);
1678
1679   /* Store it into the input event queue.  */
1680   kbd_buffer_store_event (&event);
1681
1682   XD_DEBUG_MESSAGE ("Event stored: %s", XD_OBJECT_TO_STRING (event.arg));
1683
1684   /* Cleanup.  */
1685  cleanup:
1686   dbus_message_unref (dmessage);
1687
1688   UNGCPRO;
1689 }
1690
1691 /* Read queued incoming messages of the D-Bus BUS.
1692    BUS is either a Lisp symbol, :system or :session, or a string denoting
1693    the bus address.  */
1694 static Lisp_Object
1695 xd_read_message (Lisp_Object bus)
1696 {
1697   /* Retrieve bus address.  */
1698   DBusConnection *connection = xd_get_connection_address (bus);
1699
1700   /* Non blocking read of the next available message.  */
1701   dbus_connection_read_write (connection, 0);
1702
1703   while (dbus_connection_get_dispatch_status (connection)
1704          != DBUS_DISPATCH_COMPLETE)
1705     xd_read_message_1 (connection, bus);
1706   return Qnil;
1707 }
1708
1709 /* Callback called when something is ready to read or write.  */
1710 static void
1711 xd_read_queued_messages (int fd, void *data)
1712 {
1713   Lisp_Object busp = xd_registered_buses;
1714   Lisp_Object bus = Qnil;
1715   Lisp_Object key;
1716
1717   /* Find bus related to fd.  */
1718   if (data != NULL)
1719     while (!NILP (busp))
1720       {
1721         key = CAR_SAFE (CAR_SAFE (busp));
1722         if ((SYMBOLP (key) && XSYMBOL (key) == data)
1723             || (STRINGP (key) && XSTRING (key) == data))
1724           bus = key;
1725         busp = CDR_SAFE (busp);
1726       }
1727
1728   if (NILP (bus))
1729     return;
1730
1731   /* We ignore all Lisp errors during the call.  */
1732   xd_in_read_queued_messages = 1;
1733   internal_catch (Qdbus_error, xd_read_message, bus);
1734   xd_in_read_queued_messages = 0;
1735 }
1736
1737 \f
1738 void
1739 init_dbusbind (void)
1740 {
1741   /* We do not want to abort.  */
1742   xputenv ("DBUS_FATAL_WARNINGS=0");
1743 }
1744
1745 void
1746 syms_of_dbusbind (void)
1747 {
1748
1749   DEFSYM (Qdbus__init_bus, "dbus--init-bus");
1750   defsubr (&Sdbus__init_bus);
1751
1752   DEFSYM (Qdbus_get_unique_name, "dbus-get-unique-name");
1753   defsubr (&Sdbus_get_unique_name);
1754
1755   DEFSYM (Qdbus_message_internal, "dbus-message-internal");
1756   defsubr (&Sdbus_message_internal);
1757
1758   DEFSYM (Qdbus_error, "dbus-error");
1759   Fput (Qdbus_error, Qerror_conditions,
1760         list2 (Qdbus_error, Qerror));
1761   Fput (Qdbus_error, Qerror_message,
1762         build_pure_c_string ("D-Bus error"));
1763
1764   DEFSYM (QCdbus_system_bus, ":system");
1765   DEFSYM (QCdbus_session_bus, ":session");
1766   DEFSYM (QCdbus_timeout, ":timeout");
1767   DEFSYM (QCdbus_type_byte, ":byte");
1768   DEFSYM (QCdbus_type_boolean, ":boolean");
1769   DEFSYM (QCdbus_type_int16, ":int16");
1770   DEFSYM (QCdbus_type_uint16, ":uint16");
1771   DEFSYM (QCdbus_type_int32, ":int32");
1772   DEFSYM (QCdbus_type_uint32, ":uint32");
1773   DEFSYM (QCdbus_type_int64, ":int64");
1774   DEFSYM (QCdbus_type_uint64, ":uint64");
1775   DEFSYM (QCdbus_type_double, ":double");
1776   DEFSYM (QCdbus_type_string, ":string");
1777   DEFSYM (QCdbus_type_object_path, ":object-path");
1778   DEFSYM (QCdbus_type_signature, ":signature");
1779 #ifdef DBUS_TYPE_UNIX_FD
1780   DEFSYM (QCdbus_type_unix_fd, ":unix-fd");
1781 #endif
1782   DEFSYM (QCdbus_type_array, ":array");
1783   DEFSYM (QCdbus_type_variant, ":variant");
1784   DEFSYM (QCdbus_type_struct, ":struct");
1785   DEFSYM (QCdbus_type_dict_entry, ":dict-entry");
1786   DEFSYM (QCdbus_registered_serial, ":serial");
1787   DEFSYM (QCdbus_registered_method, ":method");
1788   DEFSYM (QCdbus_registered_signal, ":signal");
1789
1790   DEFVAR_LISP ("dbus-compiled-version",
1791                Vdbus_compiled_version,
1792     doc: /* The version of D-Bus Emacs is compiled against.  */);
1793 #ifdef DBUS_VERSION_STRING
1794   Vdbus_compiled_version = build_pure_c_string (DBUS_VERSION_STRING);
1795 #else
1796   Vdbus_compiled_version = Qnil;
1797 #endif
1798
1799   DEFVAR_LISP ("dbus-runtime-version",
1800                Vdbus_runtime_version,
1801     doc: /* The version of D-Bus Emacs runs with.  */);
1802   {
1803 #ifdef DBUS_VERSION
1804     int major, minor, micro;
1805     char s[sizeof ".." + 3 * INT_STRLEN_BOUND (int)];
1806     dbus_get_version (&major, &minor, &micro);
1807     Vdbus_runtime_version
1808       = make_formatted_string (s, "%d.%d.%d", major, minor, micro);
1809 #else
1810     Vdbus_runtime_version = Qnil;
1811 #endif
1812   }
1813
1814   DEFVAR_LISP ("dbus-message-type-invalid",
1815                Vdbus_message_type_invalid,
1816     doc: /* This value is never a valid message type.  */);
1817   Vdbus_message_type_invalid = make_number (DBUS_MESSAGE_TYPE_INVALID);
1818
1819   DEFVAR_LISP ("dbus-message-type-method-call",
1820                Vdbus_message_type_method_call,
1821     doc: /* Message type of a method call message.  */);
1822   Vdbus_message_type_method_call = make_number (DBUS_MESSAGE_TYPE_METHOD_CALL);
1823
1824   DEFVAR_LISP ("dbus-message-type-method-return",
1825                Vdbus_message_type_method_return,
1826     doc: /* Message type of a method return message.  */);
1827   Vdbus_message_type_method_return
1828     = make_number (DBUS_MESSAGE_TYPE_METHOD_RETURN);
1829
1830   DEFVAR_LISP ("dbus-message-type-error",
1831                Vdbus_message_type_error,
1832     doc: /* Message type of an error reply message.  */);
1833   Vdbus_message_type_error = make_number (DBUS_MESSAGE_TYPE_ERROR);
1834
1835   DEFVAR_LISP ("dbus-message-type-signal",
1836                Vdbus_message_type_signal,
1837     doc: /* Message type of a signal message.  */);
1838   Vdbus_message_type_signal = make_number (DBUS_MESSAGE_TYPE_SIGNAL);
1839
1840   DEFVAR_LISP ("dbus-registered-objects-table",
1841                Vdbus_registered_objects_table,
1842     doc: /* Hash table of registered functions for D-Bus.
1843
1844 There are two different uses of the hash table: for accessing
1845 registered interfaces properties, targeted by signals or method calls,
1846 and for calling handlers in case of non-blocking method call returns.
1847
1848 In the first case, the key in the hash table is the list (TYPE BUS
1849 INTERFACE MEMBER).  TYPE is one of the Lisp symbols `:method',
1850 `:signal' or `:property'.  BUS is either a Lisp symbol, `:system' or
1851 `:session', or a string denoting the bus address.  INTERFACE is a
1852 string which denotes a D-Bus interface, and MEMBER, also a string, is
1853 either a method, a signal or a property INTERFACE is offering.  All
1854 arguments but BUS must not be nil.
1855
1856 The value in the hash table is a list of quadruple lists \((UNAME
1857 SERVICE PATH OBJECT [RULE]) ...).  SERVICE is the service name as
1858 registered, UNAME is the corresponding unique name.  In case of
1859 registered methods and properties, UNAME is nil.  PATH is the object
1860 path of the sending object.  All of them can be nil, which means a
1861 wildcard then.  OBJECT is either the handler to be called when a D-Bus
1862 message, which matches the key criteria, arrives (TYPE `:method' and
1863 `:signal'), or a cons cell containing the value of the property (TYPE
1864 `:property').
1865
1866 For entries of type `:signal', there is also a fifth element RULE,
1867 which keeps the match string the signal is registered with.
1868
1869 In the second case, the key in the hash table is the list (:serial BUS
1870 SERIAL).  BUS is either a Lisp symbol, `:system' or `:session', or a
1871 string denoting the bus address.  SERIAL is the serial number of the
1872 non-blocking method call, a reply is expected.  Both arguments must
1873 not be nil.  The value in the hash table is HANDLER, the function to
1874 be called when the D-Bus reply message arrives.  */);
1875   {
1876     Lisp_Object args[2];
1877     args[0] = QCtest;
1878     args[1] = Qequal;
1879     Vdbus_registered_objects_table = Fmake_hash_table (2, args);
1880   }
1881
1882   DEFVAR_LISP ("dbus-debug", Vdbus_debug,
1883     doc: /* If non-nil, debug messages of D-Bus bindings are raised.  */);
1884 #ifdef DBUS_DEBUG
1885   Vdbus_debug = Qt;
1886   /* We can also set environment variable DBUS_VERBOSE=1 in order to
1887      see more traces.  This requires libdbus-1 to be configured with
1888      --enable-verbose-mode.  */
1889 #else
1890   Vdbus_debug = Qnil;
1891 #endif
1892
1893   /* Initialize internal objects.  */
1894   xd_registered_buses = Qnil;
1895   staticpro (&xd_registered_buses);
1896
1897   Fprovide (intern_c_string ("dbusbind"), Qnil);
1898
1899 }
1900
1901 #endif /* HAVE_DBUS */