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