src/dbusbind.c

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