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