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 # if __STDC_VERSION__ < 199901
 146 #  define XD_DEBUG_MESSAGE (void) /* Pre-C99 compilers cannot debug.  */
 147 # else
 148 #  define XD_DEBUG_MESSAGE(...)                                         \
 149   do {                                                                  \
 150     if (!NILP (Vdbus_debug))                                            \
 151       {                                                                 \
 152         char s[1024];                                                   \
 153         snprintf (s, sizeof s, __VA_ARGS__);                            \
 154         message ("%s: %s", __func__, s);                                \
 155       }                                                                 \
 156   } while (0)
 157 # endif
 158 # define XD_DEBUG_VALID_LISP_OBJECT_P(object)
 159 #endif
 160
 161 /* Check whether TYPE is a basic DBusType.  */
 162 #ifdef HAVE_DBUS_TYPE_IS_VALID
 163 #define XD_BASIC_DBUS_TYPE(type)                                        \
 164   (dbus_type_is_valid (type) && dbus_type_is_basic (type))
 165 #else
 166 #ifdef DBUS_TYPE_UNIX_FD
 167 #define XD_BASIC_DBUS_TYPE(type)                                        \
 168   ((type ==  DBUS_TYPE_BYTE)                                            \
 169    || (type ==  DBUS_TYPE_BOOLEAN)                                      \
 170    || (type ==  DBUS_TYPE_INT16)                                        \
 171    || (type ==  DBUS_TYPE_UINT16)                                       \
 172    || (type ==  DBUS_TYPE_INT32)                                        \
 173    || (type ==  DBUS_TYPE_UINT32)                                       \
 174    || (type ==  DBUS_TYPE_INT64)                                        \
 175    || (type ==  DBUS_TYPE_UINT64)                                       \
 176    || (type ==  DBUS_TYPE_DOUBLE)                                       \
 177    || (type ==  DBUS_TYPE_STRING)                                       \
 178    || (type ==  DBUS_TYPE_OBJECT_PATH)                                  \
 179    || (type ==  DBUS_TYPE_SIGNATURE)                                    \
 180    || (type ==  DBUS_TYPE_UNIX_FD))
 181 #else
 182 #define XD_BASIC_DBUS_TYPE(type)                                        \
 183   ((type ==  DBUS_TYPE_BYTE)                                            \
 184    || (type ==  DBUS_TYPE_BOOLEAN)                                      \
 185    || (type ==  DBUS_TYPE_INT16)                                        \
 186    || (type ==  DBUS_TYPE_UINT16)                                       \
 187    || (type ==  DBUS_TYPE_INT32)                                        \
 188    || (type ==  DBUS_TYPE_UINT32)                                       \
 189    || (type ==  DBUS_TYPE_INT64)                                        \
 190    || (type ==  DBUS_TYPE_UINT64)                                       \
 191    || (type ==  DBUS_TYPE_DOUBLE)                                       \
 192    || (type ==  DBUS_TYPE_STRING)                                       \
 193    || (type ==  DBUS_TYPE_OBJECT_PATH)                                  \
 194    || (type ==  DBUS_TYPE_SIGNATURE))
 195 #endif
 196 #endif
 197
 198 /* This was a macro.  On Solaris 2.11 it was said to compile for
 199    hours, when optimization is enabled.  So we have transferred it into
 200    a function.  */
 201 /* Determine the DBusType of a given Lisp symbol.  OBJECT must be one
 202    of the predefined D-Bus type symbols.  */
 203 static int
 204 xd_symbol_to_dbus_type (Lisp_Object object)
 205 {
 206   return
 207     ((EQ (object, QCdbus_type_byte)) ? DBUS_TYPE_BYTE
 208      : (EQ (object, QCdbus_type_boolean)) ? DBUS_TYPE_BOOLEAN
 209      : (EQ (object, QCdbus_type_int16)) ? DBUS_TYPE_INT16
 210      : (EQ (object, QCdbus_type_uint16)) ? DBUS_TYPE_UINT16
 211      : (EQ (object, QCdbus_type_int32)) ? DBUS_TYPE_INT32
 212      : (EQ (object, QCdbus_type_uint32)) ? DBUS_TYPE_UINT32
 213      : (EQ (object, QCdbus_type_int64)) ? DBUS_TYPE_INT64
 214      : (EQ (object, QCdbus_type_uint64)) ? DBUS_TYPE_UINT64
 215      : (EQ (object, QCdbus_type_double)) ? DBUS_TYPE_DOUBLE
 216      : (EQ (object, QCdbus_type_string)) ? DBUS_TYPE_STRING
 217      : (EQ (object, QCdbus_type_object_path)) ? DBUS_TYPE_OBJECT_PATH
 218      : (EQ (object, QCdbus_type_signature)) ? DBUS_TYPE_SIGNATURE
 219 #ifdef DBUS_TYPE_UNIX_FD
 220      : (EQ (object, QCdbus_type_unix_fd)) ? DBUS_TYPE_UNIX_FD
 221 #endif
 222      : (EQ (object, QCdbus_type_array)) ? DBUS_TYPE_ARRAY
 223      : (EQ (object, QCdbus_type_variant)) ? DBUS_TYPE_VARIANT
 224      : (EQ (object, QCdbus_type_struct)) ? DBUS_TYPE_STRUCT
 225      : (EQ (object, QCdbus_type_dict_entry)) ? DBUS_TYPE_DICT_ENTRY
 226      : DBUS_TYPE_INVALID);
 227 }
 228
 229 /* Check whether a Lisp symbol is a predefined D-Bus type symbol.  */
 230 #define XD_DBUS_TYPE_P(object)                                          \
 231   (SYMBOLP (object) && ((xd_symbol_to_dbus_type (object) != DBUS_TYPE_INVALID)))
 232
 233 /* Determine the DBusType of a given Lisp OBJECT.  It is used to
 234    convert Lisp objects, being arguments of `dbus-call-method' or
 235    `dbus-send-signal', into corresponding C values appended as
 236    arguments to a D-Bus message.  */
 237 #define XD_OBJECT_TO_DBUS_TYPE(object)                                  \
 238   ((EQ (object, Qt) || EQ (object, Qnil)) ? DBUS_TYPE_BOOLEAN           \
 239    : (NATNUMP (object)) ? DBUS_TYPE_UINT32                              \
 240    : (INTEGERP (object)) ? DBUS_TYPE_INT32                              \
 241    : (FLOATP (object)) ? DBUS_TYPE_DOUBLE                               \
 242    : (STRINGP (object)) ? DBUS_TYPE_STRING                              \
 243    : (XD_DBUS_TYPE_P (object)) ? xd_symbol_to_dbus_type (object)        \
 244    : (CONSP (object))                                                   \
 245    ? ((XD_DBUS_TYPE_P (CAR_SAFE (object)))                              \
 246       ? ((XD_BASIC_DBUS_TYPE (xd_symbol_to_dbus_type (CAR_SAFE (object)))) \
 247          ? DBUS_TYPE_ARRAY                                              \
 248          : xd_symbol_to_dbus_type (CAR_SAFE (object)))                  \
 249       : DBUS_TYPE_ARRAY)                                                \
 250    : DBUS_TYPE_INVALID)
 251
 252 /* Return a list pointer which does not have a Lisp symbol as car.  */
 253 #define XD_NEXT_VALUE(object)                                           \
 254   ((XD_DBUS_TYPE_P (CAR_SAFE (object))) ? CDR_SAFE (object) : object)
 255
 256 /* Transform the message type to its string representation for debug
 257    messages.  */
 258 #define XD_MESSAGE_TYPE_TO_STRING(mtype)                                \
 259   ((mtype == DBUS_MESSAGE_TYPE_INVALID)                                 \
 260   ? "DBUS_MESSAGE_TYPE_INVALID"                                         \
 261   : (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)                            \
 262   ? "DBUS_MESSAGE_TYPE_METHOD_CALL"                                     \
 263   : (mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)                          \
 264   ? "DBUS_MESSAGE_TYPE_METHOD_RETURN"                                   \
 265   : (mtype == DBUS_MESSAGE_TYPE_ERROR)                                  \
 266    ? "DBUS_MESSAGE_TYPE_ERROR"                                          \
 267    : "DBUS_MESSAGE_TYPE_SIGNAL")
 268
 269 /* Transform the object to its string representation for debug
 270    messages.  */
 271 #define XD_OBJECT_TO_STRING(object)                                     \
 272   SDATA (format2 ("%s", object, Qnil))
 273
 274 #define XD_DBUS_VALIDATE_BUS_ADDRESS(bus)                               \
 275   do {                                                                  \
 276     char const *session_bus_address = getenv ("DBUS_SESSION_BUS_ADDRESS"); \
 277     if (STRINGP (bus))                                                  \
 278       {                                                                 \
 279         DBusAddressEntry **entries;                                     \
 280         int len;                                                        \
 281         DBusError derror;                                               \
 282         dbus_error_init (&derror);                                      \
 283         if (!dbus_parse_address (SSDATA (bus), &entries, &len, &derror)) \
 284           XD_ERROR (derror);                                            \
 285         /* Cleanup.  */                                                 \
 286         dbus_error_free (&derror);                                      \
 287         dbus_address_entries_free (entries);                            \
 288         /* Canonicalize session bus address.  */                        \
 289         if ((session_bus_address != NULL)                               \
 290             && (!NILP (Fstring_equal                                    \
 291                        (bus, build_string (session_bus_address)))))     \
 292           bus = QCdbus_session_bus;                                     \
 293       }                                                                 \
 294                                                                         \
 295     else                                                                \
 296       {                                                                 \
 297         CHECK_SYMBOL (bus);                                             \
 298         if (!(EQ (bus, QCdbus_system_bus) || EQ (bus, QCdbus_session_bus))) \
 299           XD_SIGNAL2 (build_string ("Wrong bus name"), bus);            \
 300         /* We do not want to have an autolaunch for the session bus.  */ \
 301         if (EQ (bus, QCdbus_session_bus) && session_bus_address == NULL) \
 302           XD_SIGNAL2 (build_string ("No connection to bus"), bus);      \
 303       }                                                                 \
 304   } while (0)
 305
 306 #if (HAVE_DBUS_VALIDATE_BUS_NAME || HAVE_DBUS_VALIDATE_PATH             \
 307      || HAVE_DBUS_VALIDATE_INTERFACE || HAVE_DBUS_VALIDATE_MEMBER)
 308 #define XD_DBUS_VALIDATE_OBJECT(object, func)                           \
 309   do {                                                                  \
 310     if (!NILP (object))                                                 \
 311       {                                                                 \
 312         DBusError derror;                                               \
 313         CHECK_STRING (object);                                          \
 314         dbus_error_init (&derror);                                      \
 315         if (!func (SSDATA (object), &derror))                           \
 316           XD_ERROR (derror);                                            \
 317         /* Cleanup.  */                                                 \
 318         dbus_error_free (&derror);                                      \
 319       }                                                                 \
 320   } while (0)
 321 #endif
 322
 323 #if HAVE_DBUS_VALIDATE_BUS_NAME
 324 #define XD_DBUS_VALIDATE_BUS_NAME(bus_name)                             \
 325   XD_DBUS_VALIDATE_OBJECT(bus_name, dbus_validate_bus_name);
 326 #else
 327 #define XD_DBUS_VALIDATE_BUS_NAME(bus_name)                             \
 328   if (!NILP (bus_name)) CHECK_STRING (bus_name);
 329 #endif
 330
 331 #if HAVE_DBUS_VALIDATE_PATH
 332 #define XD_DBUS_VALIDATE_PATH(path)                                     \
 333   XD_DBUS_VALIDATE_OBJECT(path, dbus_validate_path);
 334 #else
 335 #define XD_DBUS_VALIDATE_PATH(path)                                     \
 336   if (!NILP (path)) CHECK_STRING (path);
 337 #endif
 338
 339 #if HAVE_DBUS_VALIDATE_INTERFACE
 340 #define XD_DBUS_VALIDATE_INTERFACE(interface)                           \
 341   XD_DBUS_VALIDATE_OBJECT(interface, dbus_validate_interface);
 342 #else
 343 #define XD_DBUS_VALIDATE_INTERFACE(interface)                           \
 344   if (!NILP (interface)) CHECK_STRING (interface);
 345 #endif
 346
 347 #if HAVE_DBUS_VALIDATE_MEMBER
 348 #define XD_DBUS_VALIDATE_MEMBER(member)                                 \
 349   XD_DBUS_VALIDATE_OBJECT(member, dbus_validate_member);
 350 #else
 351 #define XD_DBUS_VALIDATE_MEMBER(member)                                 \
 352   if (!NILP (member)) CHECK_STRING (member);
 353 #endif
 354
 355 /* Append to SIGNATURE a copy of X, making sure SIGNATURE does
 356    not become too long.  */
 357 static void
 358 xd_signature_cat (char *signature, char const *x)
 359 {
 360   ptrdiff_t siglen = strlen (signature);
 361   ptrdiff_t xlen = strlen (x);
 362   if (DBUS_MAXIMUM_SIGNATURE_LENGTH - xlen <= siglen)
 363     string_overflow ();
 364   strcat (signature, x);
 365 }
 366
 367 /* Compute SIGNATURE of OBJECT.  It must have a form that it can be
 368    used in dbus_message_iter_open_container.  DTYPE is the DBusType
 369    the object is related to.  It is passed as argument, because it
 370    cannot be detected in basic type objects, when they are preceded by
 371    a type symbol.  PARENT_TYPE is the DBusType of a container this
 372    signature is embedded, or DBUS_TYPE_INVALID.  It is needed for the
 373    check that DBUS_TYPE_DICT_ENTRY occurs only as array element.  */
 374 static void
 375 xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object)
 376 {
 377   int subtype;
 378   Lisp_Object elt;
 379   char const *subsig;
 380   int subsiglen;
 381   char x[DBUS_MAXIMUM_SIGNATURE_LENGTH];
 382
 383   elt = object;
 384
 385   switch (dtype)
 386     {
 387     case DBUS_TYPE_BYTE:
 388     case DBUS_TYPE_UINT16:
 389       CHECK_NATNUM (object);
 390       sprintf (signature, "%c", dtype);
 391       break;
 392
 393     case DBUS_TYPE_BOOLEAN:
 394       if (!EQ (object, Qt) && !EQ (object, Qnil))
 395         wrong_type_argument (intern ("booleanp"), object);
 396       sprintf (signature, "%c", dtype);
 397       break;
 398
 399     case DBUS_TYPE_INT16:
 400       CHECK_NUMBER (object);
 401       sprintf (signature, "%c", dtype);
 402       break;
 403
 404     case DBUS_TYPE_UINT32:
 405     case DBUS_TYPE_UINT64:
 406 #ifdef DBUS_TYPE_UNIX_FD
 407     case DBUS_TYPE_UNIX_FD:
 408 #endif
 409     case DBUS_TYPE_INT32:
 410     case DBUS_TYPE_INT64:
 411     case DBUS_TYPE_DOUBLE:
 412       CHECK_NUMBER_OR_FLOAT (object);
 413       sprintf (signature, "%c", dtype);
 414       break;
 415
 416     case DBUS_TYPE_STRING:
 417     case DBUS_TYPE_OBJECT_PATH:
 418     case DBUS_TYPE_SIGNATURE:
 419       CHECK_STRING (object);
 420       sprintf (signature, "%c", dtype);
 421       break;
 422
 423     case DBUS_TYPE_ARRAY:
 424       /* Check that all list elements have the same D-Bus type.  For
 425          complex element types, we just check the container type, not
 426          the whole element's signature.  */
 427       CHECK_CONS (object);
 428
 429       /* Type symbol is optional.  */
 430       if (EQ (QCdbus_type_array, CAR_SAFE (elt)))
 431         elt = XD_NEXT_VALUE (elt);
 432
 433       /* If the array is empty, DBUS_TYPE_STRING is the default
 434          element type.  */
 435       if (NILP (elt))
 436         {
 437           subtype = DBUS_TYPE_STRING;
 438           subsig = DBUS_TYPE_STRING_AS_STRING;
 439         }
 440       else
 441         {
 442           subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
 443           xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
 444           subsig = x;
 445         }
 446
 447       /* If the element type is DBUS_TYPE_SIGNATURE, and this is the
 448          only element, the value of this element is used as the
 449          array's element signature.  */
 450       if ((subtype == DBUS_TYPE_SIGNATURE)
 451           && STRINGP (CAR_SAFE (XD_NEXT_VALUE (elt)))
 452           && NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
 453         subsig = SSDATA (CAR_SAFE (XD_NEXT_VALUE (elt)));
 454
 455       while (!NILP (elt))
 456         {
 457           if (subtype != XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt)))
 458             wrong_type_argument (intern ("D-Bus"), CAR_SAFE (elt));
 459           elt = CDR_SAFE (XD_NEXT_VALUE (elt));
 460         }
 461
 462       subsiglen = snprintf (signature, DBUS_MAXIMUM_SIGNATURE_LENGTH,
 463                             "%c%s", dtype, subsig);
 464       if (! (0 <= subsiglen && subsiglen < DBUS_MAXIMUM_SIGNATURE_LENGTH))
 465         string_overflow ();
 466       break;
 467
 468     case DBUS_TYPE_VARIANT:
 469       /* Check that there is exactly one list element.  */
 470       CHECK_CONS (object);
 471
 472       elt = XD_NEXT_VALUE (elt);
 473       subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
 474       xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
 475
 476       if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
 477         wrong_type_argument (intern ("D-Bus"),
 478                              CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt))));
 479
 480       sprintf (signature, "%c", dtype);
 481       break;
 482
 483     case DBUS_TYPE_STRUCT:
 484       /* A struct list might contain any number of elements with
 485          different types.  No further check needed.  */
 486       CHECK_CONS (object);
 487
 488       elt = XD_NEXT_VALUE (elt);
 489
 490       /* Compose the signature from the elements.  It is enclosed by
 491          parentheses.  */
 492       sprintf (signature, "%c", DBUS_STRUCT_BEGIN_CHAR );
 493       while (!NILP (elt))
 494         {
 495           subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
 496           xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
 497           xd_signature_cat (signature, x);
 498           elt = CDR_SAFE (XD_NEXT_VALUE (elt));
 499         }
 500       xd_signature_cat (signature, DBUS_STRUCT_END_CHAR_AS_STRING);
 501       break;
 502
 503     case DBUS_TYPE_DICT_ENTRY:
 504       /* Check that there are exactly two list elements, and the first
 505          one is of basic type.  The dictionary entry itself must be an
 506          element of an array.  */
 507       CHECK_CONS (object);
 508
 509       /* Check the parent object type.  */
 510       if (parent_type != DBUS_TYPE_ARRAY)
 511         wrong_type_argument (intern ("D-Bus"), object);
 512
 513       /* Compose the signature from the elements.  It is enclosed by
 514          curly braces.  */
 515       sprintf (signature, "%c", DBUS_DICT_ENTRY_BEGIN_CHAR);
 516
 517       /* First element.  */
 518       elt = XD_NEXT_VALUE (elt);
 519       subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
 520       xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
 521       xd_signature_cat (signature, x);
 522
 523       if (!XD_BASIC_DBUS_TYPE (subtype))
 524         wrong_type_argument (intern ("D-Bus"), CAR_SAFE (XD_NEXT_VALUE (elt)));
 525
 526       /* Second element.  */
 527       elt = CDR_SAFE (XD_NEXT_VALUE (elt));
 528       subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
 529       xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
 530       xd_signature_cat (signature, x);
 531
 532       if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
 533         wrong_type_argument (intern ("D-Bus"),
 534                              CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt))));
 535
 536       /* Closing signature.  */
 537       xd_signature_cat (signature, DBUS_DICT_ENTRY_END_CHAR_AS_STRING);
 538       break;
 539
 540     default:
 541       wrong_type_argument (intern ("D-Bus"), object);
 542     }
 543
 544   XD_DEBUG_MESSAGE ("%s", signature);
 545 }
 546
 547 /* Convert X to a signed integer with bounds LO and HI.  */
 548 static intmax_t
 549 xd_extract_signed (Lisp_Object x, intmax_t lo, intmax_t hi)
 550 {
 551   CHECK_NUMBER_OR_FLOAT (x);
 552   if (INTEGERP (x))
 553     {
 554       if (lo <= XINT (x) && XINT (x) <= hi)
 555         return XINT (x);
 556     }
 557   else
 558     {
 559       double d = XFLOAT_DATA (x);
 560       if (lo <= d && d <= hi)
 561         {
 562           intmax_t n = d;
 563           if (n == d)
 564             return n;
 565         }
 566     }
 567   if (xd_in_read_queued_messages)
 568     Fthrow (Qdbus_error, Qnil);
 569   else
 570     args_out_of_range_3 (x,
 571                          make_fixnum_or_float (lo),
 572                          make_fixnum_or_float (hi));
 573 }
 574
 575 /* Convert X to an unsigned integer with bounds 0 and HI.  */
 576 static uintmax_t
 577 xd_extract_unsigned (Lisp_Object x, uintmax_t hi)
 578 {
 579   CHECK_NUMBER_OR_FLOAT (x);
 580   if (INTEGERP (x))
 581     {
 582       if (0 <= XINT (x) && XINT (x) <= hi)
 583         return XINT (x);
 584     }
 585   else
 586     {
 587       double d = XFLOAT_DATA (x);
 588       if (0 <= d && d <= hi)
 589         {
 590           uintmax_t n = d;
 591           if (n == d)
 592             return n;
 593         }
 594     }
 595   if (xd_in_read_queued_messages)
 596     Fthrow (Qdbus_error, Qnil);
 597   else
 598     args_out_of_range_3 (x, make_number (0), make_fixnum_or_float (hi));
 599 }
 600
 601 /* Append C value, extracted from Lisp OBJECT, to iteration ITER.
 602    DTYPE must be a valid DBusType.  It is used to convert Lisp
 603    objects, being arguments of `dbus-call-method' or
 604    `dbus-send-signal', into corresponding C values appended as
 605    arguments to a D-Bus message.  */
 606 static void
 607 xd_append_arg (int dtype, Lisp_Object object, DBusMessageIter *iter)
 608 {
 609   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
 610   DBusMessageIter subiter;
 611
 612   if (XD_BASIC_DBUS_TYPE (dtype))
 613     switch (dtype)
 614       {
 615       case DBUS_TYPE_BYTE:
 616         CHECK_NATNUM (object);
 617         {
 618           unsigned char val = XFASTINT (object) & 0xFF;
 619           XD_DEBUG_MESSAGE ("%c %u", dtype, val);
 620           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 621             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 622           return;
 623         }
 624
 625       case DBUS_TYPE_BOOLEAN:
 626         {
 627           dbus_bool_t val = (NILP (object)) ? FALSE : TRUE;
 628           XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true");
 629           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 630             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 631           return;
 632         }
 633
 634       case DBUS_TYPE_INT16:
 635         {
 636           dbus_int16_t val =
 637             xd_extract_signed (object,
 638                                TYPE_MINIMUM (dbus_int16_t),
 639                                TYPE_MAXIMUM (dbus_int16_t));
 640           int pval = val;
 641           XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
 642           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 643             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 644           return;
 645         }
 646
 647       case DBUS_TYPE_UINT16:
 648         {
 649           dbus_uint16_t val =
 650             xd_extract_unsigned (object,
 651                                  TYPE_MAXIMUM (dbus_uint16_t));
 652           unsigned int pval = val;
 653           XD_DEBUG_MESSAGE ("%c %u", dtype, pval);
 654           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 655             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 656           return;
 657         }
 658
 659       case DBUS_TYPE_INT32:
 660         {
 661           dbus_int32_t val =
 662             xd_extract_signed (object,
 663                                TYPE_MINIMUM (dbus_int32_t),
 664                                TYPE_MAXIMUM (dbus_int32_t));
 665           int pval = val;
 666           XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
 667           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 668             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 669           return;
 670         }
 671
 672       case DBUS_TYPE_UINT32:
 673 #ifdef DBUS_TYPE_UNIX_FD
 674       case DBUS_TYPE_UNIX_FD:
 675 #endif
 676         {
 677           dbus_uint32_t val =
 678             xd_extract_unsigned (object,
 679                                  TYPE_MAXIMUM (dbus_uint32_t));
 680           unsigned int pval = val;
 681           XD_DEBUG_MESSAGE ("%c %u", dtype, pval);
 682           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 683             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 684           return;
 685         }
 686
 687       case DBUS_TYPE_INT64:
 688         {
 689           dbus_int64_t val =
 690             xd_extract_signed (object,
 691                                TYPE_MINIMUM (dbus_int64_t),
 692                                TYPE_MAXIMUM (dbus_int64_t));
 693           printmax_t pval = val;
 694           XD_DEBUG_MESSAGE ("%c %"pMd, dtype, pval);
 695           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 696             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 697           return;
 698         }
 699
 700       case DBUS_TYPE_UINT64:
 701         {
 702           dbus_uint64_t val =
 703             xd_extract_unsigned (object,
 704                                  TYPE_MAXIMUM (dbus_uint64_t));
 705           uprintmax_t pval = val;
 706           XD_DEBUG_MESSAGE ("%c %"pMu, dtype, pval);
 707           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 708             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 709           return;
 710         }
 711
 712       case DBUS_TYPE_DOUBLE:
 713         {
 714           double val = extract_float (object);
 715           XD_DEBUG_MESSAGE ("%c %f", dtype, val);
 716           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 717             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 718           return;
 719         }
 720
 721       case DBUS_TYPE_STRING:
 722       case DBUS_TYPE_OBJECT_PATH:
 723       case DBUS_TYPE_SIGNATURE:
 724         CHECK_STRING (object);
 725         {
 726           /* We need to send a valid UTF-8 string.  We could encode `object'
 727              but by not encoding it, we guarantee it's valid utf-8, even if
 728              it contains eight-bit-bytes.  Of course, you can still send
 729              manually-crafted junk by passing a unibyte string.  */
 730           char *val = SSDATA (object);
 731           XD_DEBUG_MESSAGE ("%c %s", dtype, val);
 732           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 733             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 734           return;
 735         }
 736       }
 737
 738   else /* Compound types.  */
 739     {
 740
 741       /* All compound types except array have a type symbol.  For
 742          array, it is optional.  Skip it.  */
 743       if (!XD_BASIC_DBUS_TYPE (XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object))))
 744         object = XD_NEXT_VALUE (object);
 745
 746       /* Open new subiteration.  */
 747       switch (dtype)
 748         {
 749         case DBUS_TYPE_ARRAY:
 750           /* An array has only elements of the same type.  So it is
 751              sufficient to check the first element's signature
 752              only.  */
 753
 754           if (NILP (object))
 755             /* If the array is empty, DBUS_TYPE_STRING is the default
 756                element type.  */
 757             strcpy (signature, DBUS_TYPE_STRING_AS_STRING);
 758
 759           else
 760             /* If the element type is DBUS_TYPE_SIGNATURE, and this is
 761                the only element, the value of this element is used as
 762                the array's element signature.  */
 763             if ((XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object))
 764                  == DBUS_TYPE_SIGNATURE)
 765                 && STRINGP (CAR_SAFE (XD_NEXT_VALUE (object)))
 766                 && NILP (CDR_SAFE (XD_NEXT_VALUE (object))))
 767               {
 768                 strcpy (signature, SSDATA (CAR_SAFE (XD_NEXT_VALUE (object))));
 769                 object = CDR_SAFE (XD_NEXT_VALUE (object));
 770               }
 771
 772             else
 773               xd_signature (signature,
 774                             XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object)),
 775                             dtype, CAR_SAFE (XD_NEXT_VALUE (object)));
 776
 777           XD_DEBUG_MESSAGE ("%c %s %s", dtype, signature,
 778                             XD_OBJECT_TO_STRING (object));
 779           if (!dbus_message_iter_open_container (iter, dtype,
 780                                                  signature, &subiter))
 781             XD_SIGNAL3 (build_string ("Cannot open container"),
 782                         make_number (dtype), build_string (signature));
 783           break;
 784
 785         case DBUS_TYPE_VARIANT:
 786           /* A variant has just one element.  */
 787           xd_signature (signature, XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object)),
 788                         dtype, CAR_SAFE (XD_NEXT_VALUE (object)));
 789
 790           XD_DEBUG_MESSAGE ("%c %s %s", dtype, signature,
 791                             XD_OBJECT_TO_STRING (object));
 792           if (!dbus_message_iter_open_container (iter, dtype,
 793                                                  signature, &subiter))
 794             XD_SIGNAL3 (build_string ("Cannot open container"),
 795                         make_number (dtype), build_string (signature));
 796           break;
 797
 798         case DBUS_TYPE_STRUCT:
 799         case DBUS_TYPE_DICT_ENTRY:
 800           /* These containers do not require a signature.  */
 801           XD_DEBUG_MESSAGE ("%c %s", dtype, XD_OBJECT_TO_STRING (object));
 802           if (!dbus_message_iter_open_container (iter, dtype, NULL, &subiter))
 803             XD_SIGNAL2 (build_string ("Cannot open container"),
 804                         make_number (dtype));
 805           break;
 806         }
 807
 808       /* Loop over list elements.  */
 809       while (!NILP (object))
 810         {
 811           dtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object));
 812           object = XD_NEXT_VALUE (object);
 813
 814           xd_append_arg (dtype, CAR_SAFE (object), &subiter);
 815
 816           object = CDR_SAFE (object);
 817         }
 818
 819       /* Close the subiteration.  */
 820       if (!dbus_message_iter_close_container (iter, &subiter))
 821         XD_SIGNAL2 (build_string ("Cannot close container"),
 822                     make_number (dtype));
 823     }
 824 }
 825
 826 /* Retrieve C value from a DBusMessageIter structure ITER, and return
 827    a converted Lisp object.  The type DTYPE of the argument of the
 828    D-Bus message must be a valid DBusType.  Compound D-Bus types
 829    result always in a Lisp list.  */
 830 static Lisp_Object
 831 xd_retrieve_arg (int dtype, DBusMessageIter *iter)
 832 {
 833
 834   switch (dtype)
 835     {
 836     case DBUS_TYPE_BYTE:
 837       {
 838         unsigned int val;
 839         dbus_message_iter_get_basic (iter, &val);
 840         val = val & 0xFF;
 841         XD_DEBUG_MESSAGE ("%c %u", dtype, val);
 842         return make_number (val);
 843       }
 844
 845     case DBUS_TYPE_BOOLEAN:
 846       {
 847         dbus_bool_t val;
 848         dbus_message_iter_get_basic (iter, &val);
 849         XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true");
 850         return (val == FALSE) ? Qnil : Qt;
 851       }
 852
 853     case DBUS_TYPE_INT16:
 854       {
 855         dbus_int16_t val;
 856         int pval;
 857         dbus_message_iter_get_basic (iter, &val);
 858         pval = val;
 859         XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
 860         return make_number (val);
 861       }
 862
 863     case DBUS_TYPE_UINT16:
 864       {
 865         dbus_uint16_t val;
 866         int pval;
 867         dbus_message_iter_get_basic (iter, &val);
 868         pval = val;
 869         XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
 870         return make_number (val);
 871       }
 872
 873     case DBUS_TYPE_INT32:
 874       {
 875         dbus_int32_t val;
 876         int pval;
 877         dbus_message_iter_get_basic (iter, &val);
 878         pval = val;
 879         XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
 880         return make_fixnum_or_float (val);
 881       }
 882
 883     case DBUS_TYPE_UINT32:
 884 #ifdef DBUS_TYPE_UNIX_FD
 885     case DBUS_TYPE_UNIX_FD:
 886 #endif
 887       {
 888         dbus_uint32_t val;
 889         unsigned int pval;
 890         dbus_message_iter_get_basic (iter, &val);
 891         pval = val;
 892         XD_DEBUG_MESSAGE ("%c %u", dtype, pval);
 893         return make_fixnum_or_float (val);
 894       }
 895
 896     case DBUS_TYPE_INT64:
 897       {
 898         dbus_int64_t val;
 899         printmax_t pval;
 900         dbus_message_iter_get_basic (iter, &val);
 901         pval = val;
 902         XD_DEBUG_MESSAGE ("%c %"pMd, dtype, pval);
 903         return make_fixnum_or_float (val);
 904       }
 905
 906     case DBUS_TYPE_UINT64:
 907       {
 908         dbus_uint64_t val;
 909         uprintmax_t pval;
 910         dbus_message_iter_get_basic (iter, &val);
 911         pval = val;
 912         XD_DEBUG_MESSAGE ("%c %"pMd, dtype, pval);
 913         return make_fixnum_or_float (val);
 914       }
 915
 916     case DBUS_TYPE_DOUBLE:
 917       {
 918         double val;
 919         dbus_message_iter_get_basic (iter, &val);
 920         XD_DEBUG_MESSAGE ("%c %f", dtype, val);
 921         return make_float (val);
 922       }
 923
 924     case DBUS_TYPE_STRING:
 925     case DBUS_TYPE_OBJECT_PATH:
 926     case DBUS_TYPE_SIGNATURE:
 927       {
 928         char *val;
 929         dbus_message_iter_get_basic (iter, &val);
 930         XD_DEBUG_MESSAGE ("%c %s", dtype, val);
 931         return build_string (val);
 932       }
 933
 934     case DBUS_TYPE_ARRAY:
 935     case DBUS_TYPE_VARIANT:
 936     case DBUS_TYPE_STRUCT:
 937     case DBUS_TYPE_DICT_ENTRY:
 938       {
 939         Lisp_Object result;
 940         struct gcpro gcpro1;
 941         DBusMessageIter subiter;
 942         int subtype;
 943         result = Qnil;
 944         GCPRO1 (result);
 945         dbus_message_iter_recurse (iter, &subiter);
 946         while ((subtype = dbus_message_iter_get_arg_type (&subiter))
 947                != DBUS_TYPE_INVALID)
 948           {
 949             result = Fcons (xd_retrieve_arg (subtype, &subiter), result);
 950             dbus_message_iter_next (&subiter);
 951           }
 952         XD_DEBUG_MESSAGE ("%c %s", dtype, XD_OBJECT_TO_STRING (result));
 953         RETURN_UNGCPRO (Fnreverse (result));
 954       }
 955
 956     default:
 957       XD_DEBUG_MESSAGE ("DBusType '%c' not supported", dtype);
 958       return Qnil;
 959     }
 960 }
 961
 962 /* Return the number of references of the shared CONNECTION.  */
 963 static ptrdiff_t
 964 xd_get_connection_references (DBusConnection *connection)
 965 {
 966   ptrdiff_t *refcount;
 967
 968   /* We cannot access the DBusConnection structure, it is not public.
 969      But we know, that the reference counter is the first field in
 970      that structure.  */
 971   refcount = (void *) &connection;
 972   refcount =  (void *) *refcount;
 973   return *refcount;
 974 }
 975
 976 /* Convert a Lisp D-Bus object to a pointer.  */
 977 static DBusConnection*
 978 xd_lisp_dbus_to_dbus (Lisp_Object bus)
 979 {
 980   return (DBusConnection *) (intptr_t) XFASTINT (bus);
 981 }
 982
 983 /* Return D-Bus connection address.  BUS is either a Lisp symbol,
 984    :system or :session, or a string denoting the bus address.  */
 985 static DBusConnection *
 986 xd_get_connection_address (Lisp_Object bus)
 987 {
 988   DBusConnection *connection;
 989   Lisp_Object val;
 990
 991   val = CDR_SAFE (Fassoc (bus, xd_registered_buses));
 992   if (NILP (val))
 993     XD_SIGNAL2 (build_string ("No connection to bus"), bus);
 994   else
 995     connection = xd_lisp_dbus_to_dbus (val);
 996
 997   if (!dbus_connection_get_is_connected (connection))
 998     XD_SIGNAL2 (build_string ("No connection to bus"), bus);
 999
1000   return connection;
1001 }
1002
1003 /* Return the file descriptor for WATCH, -1 if not found.  */
1004 static int
1005 xd_find_watch_fd (DBusWatch *watch)
1006 {
1007 #if HAVE_DBUS_WATCH_GET_UNIX_FD
1008   /* TODO: Reverse these on w32, which prefers the opposite.  */
1009   int fd = dbus_watch_get_unix_fd (watch);
1010   if (fd == -1)
1011     fd = dbus_watch_get_socket (watch);
1012 #else
1013   int fd = dbus_watch_get_fd (watch);
1014 #endif
1015   return fd;
1016 }
1017
1018 /* Prototype.  */
1019 static void xd_read_queued_messages (int fd, void *data);
1020
1021 /* Start monitoring WATCH for possible I/O.  */
1022 static dbus_bool_t
1023 xd_add_watch (DBusWatch *watch, void *data)
1024 {
1025   unsigned int flags = dbus_watch_get_flags (watch);
1026   int fd = xd_find_watch_fd (watch);
1027
1028   XD_DEBUG_MESSAGE ("fd %d, write %d, enabled %d",
1029                     fd, flags & DBUS_WATCH_WRITABLE,
1030                     dbus_watch_get_enabled (watch));
1031
1032   if (fd == -1)
1033     return FALSE;
1034
1035   if (dbus_watch_get_enabled (watch))
1036     {
1037       if (flags & DBUS_WATCH_WRITABLE)
1038         add_write_fd (fd, xd_read_queued_messages, data);
1039       if (flags & DBUS_WATCH_READABLE)
1040         add_read_fd (fd, xd_read_queued_messages, data);
1041     }
1042   return TRUE;
1043 }
1044
1045 /* Stop monitoring WATCH for possible I/O.
1046    DATA is the used bus, either a string or QCdbus_system_bus or
1047    QCdbus_session_bus.  */
1048 static void
1049 xd_remove_watch (DBusWatch *watch, void *data)
1050 {
1051   unsigned int flags = dbus_watch_get_flags (watch);
1052   int fd = xd_find_watch_fd (watch);
1053
1054   XD_DEBUG_MESSAGE ("fd %d", fd);
1055
1056   if (fd == -1)
1057     return;
1058
1059   /* Unset session environment.  */
1060 #if 0
1061   if (XSYMBOL (QCdbus_session_bus) == data)
1062     {
1063       XD_DEBUG_MESSAGE ("unsetenv DBUS_SESSION_BUS_ADDRESS");
1064       unsetenv ("DBUS_SESSION_BUS_ADDRESS");
1065     }
1066 #endif
1067
1068   if (flags & DBUS_WATCH_WRITABLE)
1069     delete_write_fd (fd);
1070   if (flags & DBUS_WATCH_READABLE)
1071     delete_read_fd (fd);
1072 }
1073
1074 /* Toggle monitoring WATCH for possible I/O.  */
1075 static void
1076 xd_toggle_watch (DBusWatch *watch, void *data)
1077 {
1078   if (dbus_watch_get_enabled (watch))
1079     xd_add_watch (watch, data);
1080   else
1081     xd_remove_watch (watch, data);
1082 }
1083
1084 /* Close connection to D-Bus BUS.  */
1085 static void
1086 xd_close_bus (Lisp_Object bus)
1087 {
1088   DBusConnection *connection;
1089   Lisp_Object val;
1090   Lisp_Object busobj;
1091
1092   /* Check whether we are connected.  */
1093   val = Fassoc (bus, xd_registered_buses);
1094   if (NILP (val))
1095     return;
1096
1097   busobj = CDR_SAFE(val);
1098   if (NILP (busobj)) {
1099     xd_registered_buses = Fdelete (val, xd_registered_buses);
1100     return;
1101   }
1102
1103   /* Retrieve bus address.  */
1104   connection = xd_lisp_dbus_to_dbus (busobj);
1105
1106   if (xd_get_connection_references (connection) == 1)
1107     {
1108       /* Close connection, if there isn't another shared application.  */
1109       XD_DEBUG_MESSAGE ("Close connection to bus %s",
1110                         XD_OBJECT_TO_STRING (bus));
1111       dbus_connection_close (connection);
1112
1113       xd_registered_buses = Fdelete (val, xd_registered_buses);
1114     }
1115
1116   else
1117     /* Decrement reference count.  */
1118     dbus_connection_unref (connection);
1119
1120   /* Return.  */
1121   return;
1122 }
1123
1124 DEFUN ("dbus-init-bus", Fdbus_init_bus, Sdbus_init_bus, 1, 2, 0,
1125        doc: /* Establish the connection to D-Bus 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       /* We do not want to abort.  */
1224       xputenv ("DBUS_FATAL_WARNINGS=0");
1225
1226       /* Cleanup.  */
1227       dbus_error_free (&derror);
1228     }
1229
1230   /* Return reference counter.  */
1231   refcount = xd_get_connection_references (connection);
1232   XD_DEBUG_MESSAGE ("Bus %s, Reference counter %"pD"d",
1233                     XD_OBJECT_TO_STRING (bus), refcount);
1234   return make_number (refcount);
1235 }
1236
1237 DEFUN ("dbus-get-unique-name", Fdbus_get_unique_name, Sdbus_get_unique_name,
1238        1, 1, 0,
1239        doc: /* Return the unique name of Emacs registered at D-Bus BUS.  */)
1240   (Lisp_Object bus)
1241 {
1242   DBusConnection *connection;
1243   const char *name;
1244
1245   /* Check parameter.  */
1246   XD_DBUS_VALIDATE_BUS_ADDRESS (bus);
1247
1248   /* Retrieve bus address.  */
1249   connection = xd_get_connection_address (bus);
1250
1251   /* Request the name.  */
1252   name = dbus_bus_get_unique_name (connection);
1253   if (name == NULL)
1254     XD_SIGNAL1 (build_string ("No unique name available"));
1255
1256   /* Return.  */
1257   return build_string (name);
1258 }
1259
1260 DEFUN ("dbus-message-internal", Fdbus_message_internal, Sdbus_message_internal,
1261        4, MANY, 0,
1262        doc: /* Send a D-Bus message.
1263 This is an internal function, it shall not be used outside dbus.el.
1264
1265 The following usages are expected:
1266
1267 `dbus-call-method', `dbus-call-method-asynchronously':
1268   \(dbus-message-internal
1269     dbus-message-type-method-call BUS SERVICE PATH INTERFACE METHOD HANDLER
1270     &optional :timeout TIMEOUT &rest ARGS)
1271
1272 `dbus-send-signal':
1273   \(dbus-message-internal
1274     dbus-message-type-signal BUS SERVICE PATH INTERFACE SIGNAL &rest ARGS)
1275
1276 `dbus-method-return-internal':
1277   \(dbus-message-internal
1278     dbus-message-type-method-return BUS SERVICE SERIAL &rest ARGS)
1279
1280 `dbus-method-error-internal':
1281   \(dbus-message-internal
1282     dbus-message-type-error BUS SERVICE SERIAL &rest ARGS)
1283
1284 usage: (dbus-message-internal &rest REST)  */)
1285   (ptrdiff_t nargs, Lisp_Object *args)
1286 {
1287   Lisp_Object message_type, bus, service, handler;
1288   Lisp_Object path = Qnil;
1289   Lisp_Object interface = Qnil;
1290   Lisp_Object member = Qnil;
1291   Lisp_Object result;
1292   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5, gcpro6;
1293   DBusConnection *connection;
1294   DBusMessage *dmessage;
1295   DBusMessageIter iter;
1296   int dtype;
1297   int mtype;
1298   dbus_uint32_t serial = 0;
1299   unsigned int ui_serial;
1300   int timeout = -1;
1301   ptrdiff_t count;
1302   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1303
1304   /* Initialize parameters.  */
1305   message_type = args[0];
1306   bus = args[1];
1307   service = args[2];
1308   handler = Qnil;
1309
1310   CHECK_NATNUM (message_type);
1311   if (! (DBUS_MESSAGE_TYPE_INVALID < XFASTINT (message_type)
1312          && XFASTINT (message_type) < DBUS_NUM_MESSAGE_TYPES))
1313     XD_SIGNAL2 (build_string ("Invalid message type"), message_type);
1314   mtype = XFASTINT (message_type);
1315
1316   if ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1317       || (mtype == DBUS_MESSAGE_TYPE_SIGNAL))
1318     {
1319       path = args[3];
1320       interface = args[4];
1321       member = args[5];
1322       if (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1323         handler = args[6];
1324       count = (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL) ? 7 : 6;
1325     }
1326   else /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR  */
1327     {
1328       serial = xd_extract_unsigned (args[3], TYPE_MAXIMUM (dbus_uint32_t));
1329       count = 4;
1330     }
1331
1332   /* Check parameters.  */
1333   XD_DBUS_VALIDATE_BUS_ADDRESS (bus);
1334   XD_DBUS_VALIDATE_BUS_NAME (service);
1335   if (nargs < count)
1336     xsignal2 (Qwrong_number_of_arguments,
1337               Qdbus_message_internal,
1338               make_number (nargs));
1339
1340   if ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1341       || (mtype == DBUS_MESSAGE_TYPE_SIGNAL))
1342     {
1343       XD_DBUS_VALIDATE_PATH (path);
1344       XD_DBUS_VALIDATE_INTERFACE (interface);
1345       XD_DBUS_VALIDATE_MEMBER (member);
1346       if (!NILP (handler) && (!FUNCTIONP (handler)))
1347         wrong_type_argument (Qinvalid_function, handler);
1348     }
1349
1350   /* Protect Lisp variables.  */
1351   GCPRO6 (bus, service, path, interface, member, handler);
1352
1353   /* Trace parameters.  */
1354   switch (mtype)
1355     {
1356     case DBUS_MESSAGE_TYPE_METHOD_CALL:
1357       XD_DEBUG_MESSAGE ("%s %s %s %s %s %s %s",
1358                         XD_MESSAGE_TYPE_TO_STRING (mtype),
1359                         XD_OBJECT_TO_STRING (bus),
1360                         XD_OBJECT_TO_STRING (service),
1361                         XD_OBJECT_TO_STRING (path),
1362                         XD_OBJECT_TO_STRING (interface),
1363                         XD_OBJECT_TO_STRING (member),
1364                         XD_OBJECT_TO_STRING (handler));
1365       break;
1366     case DBUS_MESSAGE_TYPE_SIGNAL:
1367       XD_DEBUG_MESSAGE ("%s %s %s %s %s %s",
1368                         XD_MESSAGE_TYPE_TO_STRING (mtype),
1369                         XD_OBJECT_TO_STRING (bus),
1370                         XD_OBJECT_TO_STRING (service),
1371                         XD_OBJECT_TO_STRING (path),
1372                         XD_OBJECT_TO_STRING (interface),
1373                         XD_OBJECT_TO_STRING (member));
1374       break;
1375     default: /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR  */
1376       ui_serial = serial;
1377       XD_DEBUG_MESSAGE ("%s %s %s %u",
1378                         XD_MESSAGE_TYPE_TO_STRING (mtype),
1379                         XD_OBJECT_TO_STRING (bus),
1380                         XD_OBJECT_TO_STRING (service),
1381                         ui_serial);
1382     }
1383
1384   /* Retrieve bus address.  */
1385   connection = xd_get_connection_address (bus);
1386
1387   /* Create the D-Bus message.  */
1388   dmessage = dbus_message_new (mtype);
1389   if (dmessage == NULL)
1390     {
1391       UNGCPRO;
1392       XD_SIGNAL1 (build_string ("Unable to create a new message"));
1393     }
1394
1395   if (STRINGP (service))
1396     {
1397       if (mtype != DBUS_MESSAGE_TYPE_SIGNAL)
1398         /* Set destination.  */
1399         {
1400           if (!dbus_message_set_destination (dmessage, SSDATA (service)))
1401             {
1402               UNGCPRO;
1403               XD_SIGNAL2 (build_string ("Unable to set the destination"),
1404                           service);
1405             }
1406         }
1407
1408       else
1409         /* Set destination for unicast signals.  */
1410         {
1411           Lisp_Object uname;
1412
1413           /* If it is the same unique name as we are registered at the
1414              bus or an unknown name, we regard it as broadcast message
1415              due to backward compatibility.  */
1416           if (dbus_bus_name_has_owner (connection, SSDATA (service), NULL))
1417             uname = call2 (intern ("dbus-get-name-owner"), bus, service);
1418           else
1419             uname = Qnil;
1420
1421           if (STRINGP (uname)
1422               && (strcmp (dbus_bus_get_unique_name (connection), SSDATA (uname))
1423                   != 0)
1424               && (!dbus_message_set_destination (dmessage, SSDATA (service))))
1425             {
1426               UNGCPRO;
1427               XD_SIGNAL2 (build_string ("Unable to set signal destination"),
1428                           service);
1429             }
1430         }
1431     }
1432
1433   /* Set message parameters.  */
1434   if ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1435       || (mtype == DBUS_MESSAGE_TYPE_SIGNAL))
1436     {
1437       if ((!dbus_message_set_path (dmessage, SSDATA (path)))
1438           || (!dbus_message_set_interface (dmessage, SSDATA (interface)))
1439           || (!dbus_message_set_member (dmessage, SSDATA (member))))
1440         {
1441           UNGCPRO;
1442           XD_SIGNAL1 (build_string ("Unable to set the message parameter"));
1443         }
1444     }
1445
1446   else /* DBUS_MESSAGE_TYPE_METHOD_RETURN, DBUS_MESSAGE_TYPE_ERROR  */
1447     {
1448       if (!dbus_message_set_reply_serial (dmessage, serial))
1449         {
1450           UNGCPRO;
1451           XD_SIGNAL1 (build_string ("Unable to create a return message"));
1452         }
1453
1454       if ((mtype == DBUS_MESSAGE_TYPE_ERROR)
1455           && (!dbus_message_set_error_name (dmessage, DBUS_ERROR_FAILED)))
1456         {
1457           UNGCPRO;
1458           XD_SIGNAL1 (build_string ("Unable to create a error message"));
1459         }
1460     }
1461
1462   /* Check for timeout parameter.  */
1463   if ((count+2 <= nargs) && (EQ ((args[count]), QCdbus_timeout)))
1464     {
1465       CHECK_NATNUM (args[count+1]);
1466       timeout = min (XFASTINT (args[count+1]), INT_MAX);
1467       count = count+2;
1468     }
1469
1470   /* Initialize parameter list of message.  */
1471   dbus_message_iter_init_append (dmessage, &iter);
1472
1473   /* Append parameters to the message.  */
1474   for (; count < nargs; ++count)
1475     {
1476       dtype = XD_OBJECT_TO_DBUS_TYPE (args[count]);
1477       if (XD_DBUS_TYPE_P (args[count]))
1478         {
1479           XD_DEBUG_VALID_LISP_OBJECT_P (args[count]);
1480           XD_DEBUG_VALID_LISP_OBJECT_P (args[count+1]);
1481           XD_DEBUG_MESSAGE ("Parameter%"pD"d %s %s", count - 4,
1482                             XD_OBJECT_TO_STRING (args[count]),
1483                             XD_OBJECT_TO_STRING (args[count+1]));
1484           ++count;
1485         }
1486       else
1487         {
1488           XD_DEBUG_VALID_LISP_OBJECT_P (args[count]);
1489           XD_DEBUG_MESSAGE ("Parameter%"pD"d %s", count - 4,
1490                             XD_OBJECT_TO_STRING (args[count]));
1491         }
1492
1493       /* Check for valid signature.  We use DBUS_TYPE_INVALID as
1494          indication that there is no parent type.  */
1495       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[count]);
1496
1497       xd_append_arg (dtype, args[count], &iter);
1498     }
1499
1500   if (!NILP (handler))
1501     {
1502       /* Send the message.  The message is just added to the outgoing
1503          message queue.  */
1504       if (!dbus_connection_send_with_reply (connection, dmessage,
1505                                             NULL, timeout))
1506         {
1507           UNGCPRO;
1508           XD_SIGNAL1 (build_string ("Cannot send message"));
1509         }
1510
1511       /* The result is the key in Vdbus_registered_objects_table.  */
1512       serial = dbus_message_get_serial (dmessage);
1513       result = list3 (QCdbus_registered_serial,
1514                       bus, make_fixnum_or_float (serial));
1515
1516       /* Create a hash table entry.  */
1517       Fputhash (result, handler, Vdbus_registered_objects_table);
1518     }
1519   else
1520     {
1521       /* Send the message.  The message is just added to the outgoing
1522          message queue.  */
1523       if (!dbus_connection_send (connection, dmessage, NULL))
1524         {
1525           UNGCPRO;
1526           XD_SIGNAL1 (build_string ("Cannot send message"));
1527         }
1528
1529       result = Qnil;
1530     }
1531
1532   XD_DEBUG_MESSAGE ("Message sent: %s", XD_OBJECT_TO_STRING (result));
1533
1534   /* Cleanup.  */
1535   dbus_message_unref (dmessage);
1536
1537   /* Return the result.  */
1538   RETURN_UNGCPRO (result);
1539 }
1540
1541 /* Read one queued incoming message of the D-Bus BUS.
1542    BUS is either a Lisp symbol, :system or :session, or a string denoting
1543    the bus address.  */
1544 static void
1545 xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
1546 {
1547   Lisp_Object args, key, value;
1548   struct gcpro gcpro1;
1549   struct input_event event;
1550   DBusMessage *dmessage;
1551   DBusMessageIter iter;
1552   int dtype;
1553   int mtype;
1554   dbus_uint32_t serial;
1555   unsigned int ui_serial;
1556   const char *uname, *path, *interface, *member;
1557
1558   dmessage = dbus_connection_pop_message (connection);
1559
1560   /* Return if there is no queued message.  */
1561   if (dmessage == NULL)
1562     return;
1563
1564   /* Collect the parameters.  */
1565   args = Qnil;
1566   GCPRO1 (args);
1567
1568   /* Loop over the resulting parameters.  Construct a list.  */
1569   if (dbus_message_iter_init (dmessage, &iter))
1570     {
1571       while ((dtype = dbus_message_iter_get_arg_type (&iter))
1572              != DBUS_TYPE_INVALID)
1573         {
1574           args = Fcons (xd_retrieve_arg (dtype, &iter), args);
1575           dbus_message_iter_next (&iter);
1576         }
1577       /* The arguments are stored in reverse order.  Reorder them.  */
1578       args = Fnreverse (args);
1579     }
1580
1581   /* Read message type, message serial, unique name, object path,
1582      interface and member from the message.  */
1583   mtype = dbus_message_get_type (dmessage);
1584   ui_serial = serial =
1585     ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1586      || (mtype == DBUS_MESSAGE_TYPE_ERROR))
1587     ? dbus_message_get_reply_serial (dmessage)
1588     : dbus_message_get_serial (dmessage);
1589   uname = dbus_message_get_sender (dmessage);
1590   path = dbus_message_get_path (dmessage);
1591   interface = dbus_message_get_interface (dmessage);
1592   member = dbus_message_get_member (dmessage);
1593
1594   XD_DEBUG_MESSAGE ("Event received: %s %u %s %s %s %s %s",
1595                     XD_MESSAGE_TYPE_TO_STRING (mtype),
1596                     ui_serial, uname, path, interface, member,
1597                     XD_OBJECT_TO_STRING (args));
1598
1599   if (mtype == DBUS_MESSAGE_TYPE_INVALID)
1600     goto cleanup;
1601
1602   else if ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1603            || (mtype == DBUS_MESSAGE_TYPE_ERROR))
1604     {
1605       /* Search for a registered function of the message.  */
1606       key = list3 (QCdbus_registered_serial, bus,
1607                    make_fixnum_or_float (serial));
1608       value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1609
1610       /* There shall be exactly one entry.  Construct an event.  */
1611       if (NILP (value))
1612         goto cleanup;
1613
1614       /* Remove the entry.  */
1615       Fremhash (key, Vdbus_registered_objects_table);
1616
1617       /* Construct an event.  */
1618       EVENT_INIT (event);
1619       event.kind = DBUS_EVENT;
1620       event.frame_or_window = Qnil;
1621       event.arg = Fcons (value, args);
1622     }
1623
1624   else /* DBUS_MESSAGE_TYPE_METHOD_CALL, DBUS_MESSAGE_TYPE_SIGNAL.  */
1625     {
1626       /* Vdbus_registered_objects_table requires non-nil interface and
1627          member.  */
1628       if ((interface == NULL) || (member == NULL))
1629         goto cleanup;
1630
1631       /* Search for a registered function of the message.  */
1632       key = list4 ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1633                    ? QCdbus_registered_method
1634                    : QCdbus_registered_signal,
1635                    bus, build_string (interface), build_string (member));
1636       value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1637
1638       /* Loop over the registered functions.  Construct an event.  */
1639       while (!NILP (value))
1640         {
1641           key = CAR_SAFE (value);
1642           /* key has the structure (UNAME SERVICE PATH HANDLER).  */
1643           if (((uname == NULL)
1644                || (NILP (CAR_SAFE (key)))
1645                || (strcmp (uname, SSDATA (CAR_SAFE (key))) == 0))
1646               && ((path == NULL)
1647                   || (NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1648                   || (strcmp (path,
1649                               SSDATA (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1650                       == 0))
1651               && (!NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))))))
1652             {
1653               EVENT_INIT (event);
1654               event.kind = DBUS_EVENT;
1655               event.frame_or_window = Qnil;
1656               event.arg
1657                 = Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))), args);
1658               break;
1659             }
1660           value = CDR_SAFE (value);
1661         }
1662
1663       if (NILP (value))
1664         goto cleanup;
1665     }
1666
1667   /* Add type, serial, uname, path, interface and member to the event.  */
1668   event.arg = Fcons ((member == NULL ? Qnil : build_string (member)),
1669                      event.arg);
1670   event.arg = Fcons ((interface == NULL ? Qnil : build_string (interface)),
1671                      event.arg);
1672   event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
1673                      event.arg);
1674   event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
1675                      event.arg);
1676   event.arg = Fcons (make_fixnum_or_float (serial), event.arg);
1677   event.arg = Fcons (make_number (mtype), event.arg);
1678
1679   /* Add the bus symbol to the event.  */
1680   event.arg = Fcons (bus, event.arg);
1681
1682   /* Store it into the input event queue.  */
1683   kbd_buffer_store_event (&event);
1684
1685   XD_DEBUG_MESSAGE ("Event stored: %s", XD_OBJECT_TO_STRING (event.arg));
1686
1687   /* Cleanup.  */
1688  cleanup:
1689   dbus_message_unref (dmessage);
1690
1691   UNGCPRO;
1692 }
1693
1694 /* Read queued incoming messages of the D-Bus BUS.
1695    BUS is either a Lisp symbol, :system or :session, or a string denoting
1696    the bus address.  */
1697 static Lisp_Object
1698 xd_read_message (Lisp_Object bus)
1699 {
1700   /* Retrieve bus address.  */
1701   DBusConnection *connection = xd_get_connection_address (bus);
1702
1703   /* Non blocking read of the next available message.  */
1704   dbus_connection_read_write (connection, 0);
1705
1706   while (dbus_connection_get_dispatch_status (connection)
1707          != DBUS_DISPATCH_COMPLETE)
1708     xd_read_message_1 (connection, bus);
1709   return Qnil;
1710 }
1711
1712 /* Callback called when something is ready to read or write.  */
1713 static void
1714 xd_read_queued_messages (int fd, void *data)
1715 {
1716   Lisp_Object busp = xd_registered_buses;
1717   Lisp_Object bus = Qnil;
1718   Lisp_Object key;
1719
1720   /* Find bus related to fd.  */
1721   if (data != NULL)
1722     while (!NILP (busp))
1723       {
1724         key = CAR_SAFE (CAR_SAFE (busp));
1725         if ((SYMBOLP (key) && XSYMBOL (key) == data)
1726             || (STRINGP (key) && XSTRING (key) == data))
1727           bus = key;
1728         busp = CDR_SAFE (busp);
1729       }
1730
1731   if (NILP (bus))
1732     return;
1733
1734   /* We ignore all Lisp errors during the call.  */
1735   xd_in_read_queued_messages = 1;
1736   internal_catch (Qdbus_error, xd_read_message, bus);
1737   xd_in_read_queued_messages = 0;
1738 }
1739
1740 \f
1741 void
1742 syms_of_dbusbind (void)
1743 {
1744
1745   DEFSYM (Qdbus_init_bus, "dbus-init-bus");
1746   defsubr (&Sdbus_init_bus);
1747
1748   DEFSYM (Qdbus_get_unique_name, "dbus-get-unique-name");
1749   defsubr (&Sdbus_get_unique_name);
1750
1751   DEFSYM (Qdbus_message_internal, "dbus-message-internal");
1752   defsubr (&Sdbus_message_internal);
1753
1754   DEFSYM (Qdbus_error, "dbus-error");
1755   Fput (Qdbus_error, Qerror_conditions,
1756         list2 (Qdbus_error, Qerror));
1757   Fput (Qdbus_error, Qerror_message,
1758         build_pure_c_string ("D-Bus error"));
1759
1760   DEFSYM (QCdbus_system_bus, ":system");
1761   DEFSYM (QCdbus_session_bus, ":session");
1762   DEFSYM (QCdbus_timeout, ":timeout");
1763   DEFSYM (QCdbus_type_byte, ":byte");
1764   DEFSYM (QCdbus_type_boolean, ":boolean");
1765   DEFSYM (QCdbus_type_int16, ":int16");
1766   DEFSYM (QCdbus_type_uint16, ":uint16");
1767   DEFSYM (QCdbus_type_int32, ":int32");
1768   DEFSYM (QCdbus_type_uint32, ":uint32");
1769   DEFSYM (QCdbus_type_int64, ":int64");
1770   DEFSYM (QCdbus_type_uint64, ":uint64");
1771   DEFSYM (QCdbus_type_double, ":double");
1772   DEFSYM (QCdbus_type_string, ":string");
1773   DEFSYM (QCdbus_type_object_path, ":object-path");
1774   DEFSYM (QCdbus_type_signature, ":signature");
1775 #ifdef DBUS_TYPE_UNIX_FD
1776   DEFSYM (QCdbus_type_unix_fd, ":unix-fd");
1777 #endif
1778   DEFSYM (QCdbus_type_array, ":array");
1779   DEFSYM (QCdbus_type_variant, ":variant");
1780   DEFSYM (QCdbus_type_struct, ":struct");
1781   DEFSYM (QCdbus_type_dict_entry, ":dict-entry");
1782   DEFSYM (QCdbus_registered_serial, ":serial");
1783   DEFSYM (QCdbus_registered_method, ":method");
1784   DEFSYM (QCdbus_registered_signal, ":signal");
1785
1786   DEFVAR_LISP ("dbus-compiled-version",
1787                Vdbus_compiled_version,
1788     doc: /* The version of D-Bus Emacs is compiled against.  */);
1789 #ifdef DBUS_VERSION_STRING
1790   Vdbus_compiled_version = build_pure_c_string (DBUS_VERSION_STRING);
1791 #else
1792   Vdbus_compiled_version = Qnil;
1793 #endif
1794
1795   DEFVAR_LISP ("dbus-runtime-version",
1796                Vdbus_runtime_version,
1797     doc: /* The version of D-Bus Emacs runs with.  */);
1798   {
1799 #ifdef DBUS_VERSION
1800     int major, minor, micro;
1801     char s[sizeof ".." + 3 * INT_STRLEN_BOUND (int)];
1802     dbus_get_version (&major, &minor, &micro);
1803     Vdbus_runtime_version
1804       = make_formatted_string (s, "%d.%d.%d", major, minor, micro);
1805 #else
1806     Vdbus_runtime_version = Qnil;
1807 #endif
1808   }
1809
1810   DEFVAR_LISP ("dbus-message-type-invalid",
1811                Vdbus_message_type_invalid,
1812     doc: /* This value is never a valid message type.  */);
1813   Vdbus_message_type_invalid = make_number (DBUS_MESSAGE_TYPE_INVALID);
1814
1815   DEFVAR_LISP ("dbus-message-type-method-call",
1816                Vdbus_message_type_method_call,
1817     doc: /* Message type of a method call message.  */);
1818   Vdbus_message_type_method_call = make_number (DBUS_MESSAGE_TYPE_METHOD_CALL);
1819
1820   DEFVAR_LISP ("dbus-message-type-method-return",
1821                Vdbus_message_type_method_return,
1822     doc: /* Message type of a method return message.  */);
1823   Vdbus_message_type_method_return
1824     = make_number (DBUS_MESSAGE_TYPE_METHOD_RETURN);
1825
1826   DEFVAR_LISP ("dbus-message-type-error",
1827                Vdbus_message_type_error,
1828     doc: /* Message type of an error reply message.  */);
1829   Vdbus_message_type_error = make_number (DBUS_MESSAGE_TYPE_ERROR);
1830
1831   DEFVAR_LISP ("dbus-message-type-signal",
1832                Vdbus_message_type_signal,
1833     doc: /* Message type of a signal message.  */);
1834   Vdbus_message_type_signal = make_number (DBUS_MESSAGE_TYPE_SIGNAL);
1835
1836   DEFVAR_LISP ("dbus-registered-objects-table",
1837                Vdbus_registered_objects_table,
1838     doc: /* Hash table of registered functions for D-Bus.
1839
1840 There are two different uses of the hash table: for accessing
1841 registered interfaces properties, targeted by signals or method calls,
1842 and for calling handlers in case of non-blocking method call returns.
1843
1844 In the first case, the key in the hash table is the list (TYPE BUS
1845 INTERFACE MEMBER).  TYPE is one of the Lisp symbols `:method',
1846 `:signal' or `:property'.  BUS is either a Lisp symbol, `:system' or
1847 `:session', or a string denoting the bus address.  INTERFACE is a
1848 string which denotes a D-Bus interface, and MEMBER, also a string, is
1849 either a method, a signal or a property INTERFACE is offering.  All
1850 arguments but BUS must not be nil.
1851
1852 The value in the hash table is a list of quadruple lists \((UNAME
1853 SERVICE PATH OBJECT [RULE]) ...).  SERVICE is the service name as
1854 registered, UNAME is the corresponding unique name.  In case of
1855 registered methods and properties, UNAME is nil.  PATH is the object
1856 path of the sending object.  All of them can be nil, which means a
1857 wildcard then.  OBJECT is either the handler to be called when a D-Bus
1858 message, which matches the key criteria, arrives (TYPE `:method' and
1859 `:signal'), or a cons cell containing the value of the property (TYPE
1860 `:property').
1861
1862 For entries of type `:signal', there is also a fifth element RULE,
1863 which keeps the match string the signal is registered with.
1864
1865 In the second case, the key in the hash table is the list (:serial BUS
1866 SERIAL).  BUS is either a Lisp symbol, `:system' or `:session', or a
1867 string denoting the bus address.  SERIAL is the serial number of the
1868 non-blocking method call, a reply is expected.  Both arguments must
1869 not be nil.  The value in the hash table is HANDLER, the function to
1870 be called when the D-Bus reply message arrives.  */);
1871   {
1872     Lisp_Object args[2];
1873     args[0] = QCtest;
1874     args[1] = Qequal;
1875     Vdbus_registered_objects_table = Fmake_hash_table (2, args);
1876   }
1877
1878   DEFVAR_LISP ("dbus-debug", Vdbus_debug,
1879     doc: /* If non-nil, debug messages of D-Bus bindings are raised.  */);
1880 #ifdef DBUS_DEBUG
1881   Vdbus_debug = Qt;
1882   /* We can also set environment variable DBUS_VERBOSE=1 in order to
1883      see more traces.  This requires libdbus-1 to be configured with
1884      --enable-verbose-mode.  */
1885 #else
1886   Vdbus_debug = Qnil;
1887 #endif
1888
1889   /* Initialize internal objects.  */
1890   xd_registered_buses = Qnil;
1891   staticpro (&xd_registered_buses);
1892
1893   Fprovide (intern_c_string ("dbusbind"), Qnil);
1894
1895 }
1896
1897 #endif /* HAVE_DBUS */