src/dbusbind.c

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