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