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