src/dbusbind.c

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