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