dbusbind.c 72.2 KB
Newer Older
1
/* Elisp bindings for D-Bus.
2
   Copyright (C) 2007-2011 Free Software Foundation, Inc.
3 4 5

This file is part of GNU Emacs.

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 9
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
10 11 12 13 14 15 16

GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

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

Dan Nicolaescu's avatar
Dan Nicolaescu committed
19
#include <config.h>
20 21

#ifdef HAVE_DBUS
22
#include <stdio.h>
23
#include <dbus/dbus.h>
24
#include <setjmp.h>
25 26 27 28
#include "lisp.h"
#include "frame.h"
#include "termhooks.h"
#include "keyboard.h"
29
#include "process.h"
30 31 32


/* Subroutines.  */
33 34 35 36 37 38 39 40 41 42 43
static Lisp_Object Qdbus_init_bus;
static Lisp_Object Qdbus_close_bus;
static Lisp_Object Qdbus_get_unique_name;
static Lisp_Object Qdbus_call_method;
static Lisp_Object Qdbus_call_method_asynchronously;
static Lisp_Object Qdbus_method_return_internal;
static Lisp_Object Qdbus_method_error_internal;
static Lisp_Object Qdbus_send_signal;
static Lisp_Object Qdbus_register_service;
static Lisp_Object Qdbus_register_signal;
static Lisp_Object Qdbus_register_method;
44 45

/* D-Bus error symbol.  */
46
static Lisp_Object Qdbus_error;
47 48

/* Lisp symbols of the system and session buses.  */
49
static Lisp_Object QCdbus_system_bus, QCdbus_session_bus;
50

51
/* Lisp symbol for method call timeout.  */
52
static Lisp_Object QCdbus_timeout;
53

54
/* Lisp symbols for name request flags.  */
55 56 57
static Lisp_Object QCdbus_request_name_allow_replacement;
static Lisp_Object QCdbus_request_name_replace_existing;
static Lisp_Object QCdbus_request_name_do_not_queue;
58 59

/* Lisp symbols for name request replies.  */
60 61 62 63
static Lisp_Object QCdbus_request_name_reply_primary_owner;
static Lisp_Object QCdbus_request_name_reply_in_queue;
static Lisp_Object QCdbus_request_name_reply_exists;
static Lisp_Object QCdbus_request_name_reply_already_owner;
64

65
/* Lisp symbols of D-Bus types.  */
66 67 68 69 70 71
static Lisp_Object QCdbus_type_byte, QCdbus_type_boolean;
static Lisp_Object QCdbus_type_int16, QCdbus_type_uint16;
static Lisp_Object QCdbus_type_int32, QCdbus_type_uint32;
static Lisp_Object QCdbus_type_int64, QCdbus_type_uint64;
static Lisp_Object QCdbus_type_double, QCdbus_type_string;
static Lisp_Object QCdbus_type_object_path, QCdbus_type_signature;
72
#ifdef DBUS_TYPE_UNIX_FD
73
static Lisp_Object QCdbus_type_unix_fd;
74
#endif
75 76
static Lisp_Object QCdbus_type_array, QCdbus_type_variant;
static Lisp_Object QCdbus_type_struct, QCdbus_type_dict_entry;
77

78
/* Whether we are reading a D-Bus event.  */
79
static int xd_in_read_queued_messages = 0;
80

81 82 83 84

/* We use "xd_" and "XD_" as prefix for all internal symbols, because
   we don't want to poison other namespaces with "dbus_".  */

85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110
/* Raise a signal.  If we are reading events, we cannot signal; we
   throw to xd_read_queued_messages then.  */
#define XD_SIGNAL1(arg)							\
  do {									\
    if (xd_in_read_queued_messages)					\
      Fthrow (Qdbus_error, Qnil);					\
    else								\
      xsignal1 (Qdbus_error, arg);					\
  } while (0)

#define XD_SIGNAL2(arg1, arg2)						\
  do {									\
    if (xd_in_read_queued_messages)					\
      Fthrow (Qdbus_error, Qnil);					\
    else								\
      xsignal2 (Qdbus_error, arg1, arg2);				\
  } while (0)

#define XD_SIGNAL3(arg1, arg2, arg3)					\
  do {									\
    if (xd_in_read_queued_messages)					\
      Fthrow (Qdbus_error, Qnil);					\
    else								\
      xsignal3 (Qdbus_error, arg1, arg2, arg3);				\
  } while (0)

111
/* Raise a Lisp error from a D-Bus ERROR.  */
112
#define XD_ERROR(error)							\
113
  do {									\
114
    /* Remove the trailing newline.  */					\
115 116 117 118 119
    char const *mess = error.message;					\
    char const *nl = strchr (mess, '\n');				\
    Lisp_Object err = make_string (mess, nl ? nl - mess : strlen (mess)); \
    dbus_error_free (&error);						\
    XD_SIGNAL1 (err);							\
120
  } while (0)
121 122

/* Macros for debugging.  In order to enable them, build with
123
   "MYCPPFLAGS='-DDBUS_DEBUG -Wall' make".  */
124 125
#ifdef DBUS_DEBUG
#define XD_DEBUG_MESSAGE(...)		\
126
  do {					\
127
    char s[1024];			\
128
    snprintf (s, sizeof s, __VA_ARGS__); \
129 130
    printf ("%s: %s\n", __func__, s);	\
    message ("%s: %s", __func__, s);	\
131
  } while (0)
132
#define XD_DEBUG_VALID_LISP_OBJECT_P(object)				\
133 134 135 136
  do {									\
    if (!valid_lisp_object_p (object))					\
      {									\
	XD_DEBUG_MESSAGE ("%d Assertion failure", __LINE__);		\
137
	XD_SIGNAL1 (build_string ("Assertion failure"));		\
138 139
      }									\
  } while (0)
140 141

#else /* !DBUS_DEBUG */
142 143 144 145 146
#define XD_DEBUG_MESSAGE(...)						\
  do {									\
    if (!NILP (Vdbus_debug))						\
      {									\
	char s[1024];							\
147
	snprintf (s, 1023, __VA_ARGS__);				\
148
	message ("%s: %s", __func__, s);				\
Michael Albinus's avatar
Michael Albinus committed
149
      }									\
150
  } while (0)
151 152 153
#define XD_DEBUG_VALID_LISP_OBJECT_P(object)
#endif

154
/* Check whether TYPE is a basic DBusType.  */
155 156 157 158 159 160 161 162 163 164 165 166 167
#ifdef DBUS_TYPE_UNIX_FD
#define XD_BASIC_DBUS_TYPE(type)					\
  ((type ==  DBUS_TYPE_BYTE)						\
   || (type ==  DBUS_TYPE_BOOLEAN)					\
   || (type ==  DBUS_TYPE_INT16)					\
   || (type ==  DBUS_TYPE_UINT16)					\
   || (type ==  DBUS_TYPE_INT32)					\
   || (type ==  DBUS_TYPE_UINT32)					\
   || (type ==  DBUS_TYPE_INT64)					\
   || (type ==  DBUS_TYPE_UINT64)					\
   || (type ==  DBUS_TYPE_DOUBLE)					\
   || (type ==  DBUS_TYPE_STRING)					\
   || (type ==  DBUS_TYPE_OBJECT_PATH)					\
168
   || (type ==  DBUS_TYPE_SIGNATURE)					\
169 170
   || (type ==  DBUS_TYPE_UNIX_FD))
#else
171 172 173 174 175 176 177 178 179 180 181 182 183
#define XD_BASIC_DBUS_TYPE(type)					\
  ((type ==  DBUS_TYPE_BYTE)						\
   || (type ==  DBUS_TYPE_BOOLEAN)					\
   || (type ==  DBUS_TYPE_INT16)					\
   || (type ==  DBUS_TYPE_UINT16)					\
   || (type ==  DBUS_TYPE_INT32)					\
   || (type ==  DBUS_TYPE_UINT32)					\
   || (type ==  DBUS_TYPE_INT64)					\
   || (type ==  DBUS_TYPE_UINT64)					\
   || (type ==  DBUS_TYPE_DOUBLE)					\
   || (type ==  DBUS_TYPE_STRING)					\
   || (type ==  DBUS_TYPE_OBJECT_PATH)					\
   || (type ==  DBUS_TYPE_SIGNATURE))
184
#endif
185

186 187 188
/* This was a macro.  On Solaris 2.11 it was said to compile for
   hours, when optimzation is enabled.  So we have transferred it into
   a function.  */
189 190
/* Determine the DBusType of a given Lisp symbol.  OBJECT must be one
   of the predefined D-Bus type symbols.  */
191
static int
192
xd_symbol_to_dbus_type (Lisp_Object object)
193 194 195 196 197 198 199 200 201 202 203 204 205 206
{
  return
    ((EQ (object, QCdbus_type_byte)) ? DBUS_TYPE_BYTE
     : (EQ (object, QCdbus_type_boolean)) ? DBUS_TYPE_BOOLEAN
     : (EQ (object, QCdbus_type_int16)) ? DBUS_TYPE_INT16
     : (EQ (object, QCdbus_type_uint16)) ? DBUS_TYPE_UINT16
     : (EQ (object, QCdbus_type_int32)) ? DBUS_TYPE_INT32
     : (EQ (object, QCdbus_type_uint32)) ? DBUS_TYPE_UINT32
     : (EQ (object, QCdbus_type_int64)) ? DBUS_TYPE_INT64
     : (EQ (object, QCdbus_type_uint64)) ? DBUS_TYPE_UINT64
     : (EQ (object, QCdbus_type_double)) ? DBUS_TYPE_DOUBLE
     : (EQ (object, QCdbus_type_string)) ? DBUS_TYPE_STRING
     : (EQ (object, QCdbus_type_object_path)) ? DBUS_TYPE_OBJECT_PATH
     : (EQ (object, QCdbus_type_signature)) ? DBUS_TYPE_SIGNATURE
207 208 209
#ifdef DBUS_TYPE_UNIX_FD
     : (EQ (object, QCdbus_type_unix_fd)) ? DBUS_TYPE_UNIX_FD
#endif
210 211 212 213 214 215
     : (EQ (object, QCdbus_type_array)) ? DBUS_TYPE_ARRAY
     : (EQ (object, QCdbus_type_variant)) ? DBUS_TYPE_VARIANT
     : (EQ (object, QCdbus_type_struct)) ? DBUS_TYPE_STRUCT
     : (EQ (object, QCdbus_type_dict_entry)) ? DBUS_TYPE_DICT_ENTRY
     : DBUS_TYPE_INVALID);
}
216 217 218

/* Check whether a Lisp symbol is a predefined D-Bus type symbol.  */
#define XD_DBUS_TYPE_P(object)						\
219
  (SYMBOLP (object) && ((xd_symbol_to_dbus_type (object) != DBUS_TYPE_INVALID)))
220 221

/* Determine the DBusType of a given Lisp OBJECT.  It is used to
222 223 224
   convert Lisp objects, being arguments of `dbus-call-method' or
   `dbus-send-signal', into corresponding C values appended as
   arguments to a D-Bus message.  */
225 226 227 228 229 230
#define XD_OBJECT_TO_DBUS_TYPE(object)					\
  ((EQ (object, Qt) || EQ (object, Qnil)) ? DBUS_TYPE_BOOLEAN		\
   : (NATNUMP (object)) ? DBUS_TYPE_UINT32				\
   : (INTEGERP (object)) ? DBUS_TYPE_INT32				\
   : (FLOATP (object)) ? DBUS_TYPE_DOUBLE				\
   : (STRINGP (object)) ? DBUS_TYPE_STRING				\
231
   : (XD_DBUS_TYPE_P (object)) ? xd_symbol_to_dbus_type (object)	\
232 233
   : (CONSP (object))							\
   ? ((XD_DBUS_TYPE_P (CAR_SAFE (object)))				\
234
      ? ((XD_BASIC_DBUS_TYPE (xd_symbol_to_dbus_type (CAR_SAFE (object)))) \
235
	 ? DBUS_TYPE_ARRAY						\
236
	 : xd_symbol_to_dbus_type (CAR_SAFE (object)))			\
237
      : DBUS_TYPE_ARRAY)						\
238 239 240
   : DBUS_TYPE_INVALID)

/* Return a list pointer which does not have a Lisp symbol as car.  */
241
#define XD_NEXT_VALUE(object)						\
242
  ((XD_DBUS_TYPE_P (CAR_SAFE (object))) ? CDR_SAFE (object) : object)
243

244 245 246 247 248 249 250 251 252 253 254 255 256 257
/* Check whether X is a valid dbus serial number.  If valid, set
   SERIAL to its value.  Otherwise, signal an error. */
#define CHECK_DBUS_SERIAL_GET_SERIAL(x, serial)				\
  do									\
    {									\
      dbus_uint32_t DBUS_SERIAL_MAX = -1;				\
      if (NATNUMP (x) && XINT (x) <= DBUS_SERIAL_MAX)			\
	serial = XINT (x);						\
      else if (MOST_POSITIVE_FIXNUM < DBUS_SERIAL_MAX			\
	       && FLOATP (x)						\
	       && 0 <= XFLOAT_DATA (x)					\
	       && XFLOAT_DATA (x) <= DBUS_SERIAL_MAX)			\
	serial = XFLOAT_DATA (x);					\
      else								\
258
	XD_SIGNAL2 (build_string ("Invalid dbus serial"), x);		\
259 260 261
    }									\
  while (0)

262 263 264 265 266 267 268
/* Compute SIGNATURE of OBJECT.  It must have a form that it can be
   used in dbus_message_iter_open_container.  DTYPE is the DBusType
   the object is related to.  It is passed as argument, because it
   cannot be detected in basic type objects, when they are preceded by
   a type symbol.  PARENT_TYPE is the DBusType of a container this
   signature is embedded, or DBUS_TYPE_INVALID.  It is needed for the
   check that DBUS_TYPE_DICT_ENTRY occurs only as array element.  */
269
static void
270
xd_signature (char *signature, unsigned int dtype, unsigned int parent_type, Lisp_Object object)
271
{
272 273 274 275 276
  unsigned int subtype;
  Lisp_Object elt;
  char x[DBUS_MAXIMUM_SIGNATURE_LENGTH];

  elt = object;
277 278 279

  switch (dtype)
    {
280 281
    case DBUS_TYPE_BYTE:
    case DBUS_TYPE_UINT16:
282
    case DBUS_TYPE_UINT32:
283
    case DBUS_TYPE_UINT64:
284 285 286
#ifdef DBUS_TYPE_UNIX_FD
    case DBUS_TYPE_UNIX_FD:
#endif
287
      CHECK_NATNUM (object);
288
      sprintf (signature, "%c", dtype);
289
      break;
290

291 292 293
    case DBUS_TYPE_BOOLEAN:
      if (!EQ (object, Qt) && !EQ (object, Qnil))
	wrong_type_argument (intern ("booleanp"), object);
294
      sprintf (signature, "%c", dtype);
295
      break;
296

297
    case DBUS_TYPE_INT16:
298
    case DBUS_TYPE_INT32:
299 300
    case DBUS_TYPE_INT64:
      CHECK_NUMBER (object);
301
      sprintf (signature, "%c", dtype);
302
      break;
303

304
    case DBUS_TYPE_DOUBLE:
305
      CHECK_FLOAT (object);
306
      sprintf (signature, "%c", dtype);
307
      break;
308

309
    case DBUS_TYPE_STRING:
310 311 312
    case DBUS_TYPE_OBJECT_PATH:
    case DBUS_TYPE_SIGNATURE:
      CHECK_STRING (object);
313
      sprintf (signature, "%c", dtype);
314
      break;
315

316
    case DBUS_TYPE_ARRAY:
317
      /* Check that all list elements have the same D-Bus type.  For
318 319
	 complex element types, we just check the container type, not
	 the whole element's signature.  */
320
      CHECK_CONS (object);
321

322 323
      /* Type symbol is optional.  */
      if (EQ (QCdbus_type_array, CAR_SAFE (elt)))
324
	elt = XD_NEXT_VALUE (elt);
325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344

      /* If the array is empty, DBUS_TYPE_STRING is the default
	 element type.  */
      if (NILP (elt))
	{
	  subtype = DBUS_TYPE_STRING;
	  strcpy (x, DBUS_TYPE_STRING_AS_STRING);
	}
      else
	{
	  subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
	  xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
	}

      /* If the element type is DBUS_TYPE_SIGNATURE, and this is the
	 only element, the value of this element is used as he array's
	 element signature.  */
      if ((subtype == DBUS_TYPE_SIGNATURE)
	  && STRINGP (CAR_SAFE (XD_NEXT_VALUE (elt)))
	  && NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
345
	strcpy (x, SSDATA (CAR_SAFE (XD_NEXT_VALUE (elt))));
346 347 348

      while (!NILP (elt))
	{
349 350 351
	  if (subtype != XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt)))
	    wrong_type_argument (intern ("D-Bus"), CAR_SAFE (elt));
	  elt = CDR_SAFE (XD_NEXT_VALUE (elt));
352 353 354
	}

      sprintf (signature, "%c%s", dtype, x);
355
      break;
356

357
    case DBUS_TYPE_VARIANT:
358
      /* Check that there is exactly one list element.  */
359
      CHECK_CONS (object);
360 361

      elt = XD_NEXT_VALUE (elt);
362 363
      subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
      xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
364

365
      if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
366
	wrong_type_argument (intern ("D-Bus"),
367
			     CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt))));
368

369
      sprintf (signature, "%c", dtype);
370
      break;
371

372
    case DBUS_TYPE_STRUCT:
373 374
      /* A struct list might contain any number of elements with
	 different types.  No further check needed.  */
375 376 377 378 379 380 381 382 383
      CHECK_CONS (object);

      elt = XD_NEXT_VALUE (elt);

      /* Compose the signature from the elements.  It is enclosed by
	 parentheses.  */
      sprintf (signature, "%c", DBUS_STRUCT_BEGIN_CHAR );
      while (!NILP (elt))
	{
384 385
	  subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
	  xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
386
	  strcat (signature, x);
387
	  elt = CDR_SAFE (XD_NEXT_VALUE (elt));
388
	}
389
      strcat (signature, DBUS_STRUCT_END_CHAR_AS_STRING);
390 391
      break;

392
    case DBUS_TYPE_DICT_ENTRY:
393 394 395
      /* Check that there are exactly two list elements, and the first
	 one is of basic type.  The dictionary entry itself must be an
	 element of an array.  */
396
      CHECK_CONS (object);
397

398
      /* Check the parent object type.  */
399 400
      if (parent_type != DBUS_TYPE_ARRAY)
	wrong_type_argument (intern ("D-Bus"), object);
401

402 403 404
      /* Compose the signature from the elements.  It is enclosed by
	 curly braces.  */
      sprintf (signature, "%c", DBUS_DICT_ENTRY_BEGIN_CHAR);
405

406 407
      /* First element.  */
      elt = XD_NEXT_VALUE (elt);
408 409
      subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
      xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
410
      strcat (signature, x);
411

412
      if (!XD_BASIC_DBUS_TYPE (subtype))
413
	wrong_type_argument (intern ("D-Bus"), CAR_SAFE (XD_NEXT_VALUE (elt)));
414

415
      /* Second element.  */
416 417 418
      elt = CDR_SAFE (XD_NEXT_VALUE (elt));
      subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
      xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
419
      strcat (signature, x);
420

421
      if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
422
	wrong_type_argument (intern ("D-Bus"),
423
			     CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt))));
424

425
      /* Closing signature.  */
426
      strcat (signature, DBUS_DICT_ENTRY_END_CHAR_AS_STRING);
427
      break;
428

429 430
    default:
      wrong_type_argument (intern ("D-Bus"), object);
431 432
    }

433 434
  XD_DEBUG_MESSAGE ("%s", signature);
}
435

436 437 438 439 440
/* Append C value, extracted from Lisp OBJECT, to iteration ITER.
   DTYPE must be a valid DBusType.  It is used to convert Lisp
   objects, being arguments of `dbus-call-method' or
   `dbus-send-signal', into corresponding C values appended as
   arguments to a D-Bus message.  */
441
static void
442
xd_append_arg (unsigned int dtype, Lisp_Object object, DBusMessageIter *iter)
443 444 445 446 447
{
  char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
  DBusMessageIter subiter;

  if (XD_BASIC_DBUS_TYPE (dtype))
448 449 450
    switch (dtype)
      {
      case DBUS_TYPE_BYTE:
451
	CHECK_NATNUM (object);
452
	{
453
	  unsigned char val = XFASTINT (object) & 0xFF;
454 455
	  XD_DEBUG_MESSAGE ("%c %d", dtype, val);
	  if (!dbus_message_iter_append_basic (iter, dtype, &val))
456
	    XD_SIGNAL2 (build_string ("Unable to append argument"), object);
457 458
	  return;
	}
459

460 461 462 463 464
      case DBUS_TYPE_BOOLEAN:
	{
	  dbus_bool_t val = (NILP (object)) ? FALSE : TRUE;
	  XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true");
	  if (!dbus_message_iter_append_basic (iter, dtype, &val))
465
	    XD_SIGNAL2 (build_string ("Unable to append argument"), object);
466 467
	  return;
	}
468

469
      case DBUS_TYPE_INT16:
470
	CHECK_NUMBER (object);
471 472 473 474
	{
	  dbus_int16_t val = XINT (object);
	  XD_DEBUG_MESSAGE ("%c %d", dtype, (int) val);
	  if (!dbus_message_iter_append_basic (iter, dtype, &val))
475
	    XD_SIGNAL2 (build_string ("Unable to append argument"), object);
476 477
	  return;
	}
478

479
      case DBUS_TYPE_UINT16:
480
	CHECK_NATNUM (object);
481
	{
482
	  dbus_uint16_t val = XFASTINT (object);
483 484
	  XD_DEBUG_MESSAGE ("%c %u", dtype, (unsigned int) val);
	  if (!dbus_message_iter_append_basic (iter, dtype, &val))
485
	    XD_SIGNAL2 (build_string ("Unable to append argument"), object);
486 487
	  return;
	}
488

489
      case DBUS_TYPE_INT32:
490
	CHECK_NUMBER (object);
491 492 493 494
	{
	  dbus_int32_t val = XINT (object);
	  XD_DEBUG_MESSAGE ("%c %d", dtype, val);
	  if (!dbus_message_iter_append_basic (iter, dtype, &val))
495
	    XD_SIGNAL2 (build_string ("Unable to append argument"), object);
496 497
	  return;
	}
498

499
      case DBUS_TYPE_UINT32:
500 501 502
#ifdef DBUS_TYPE_UNIX_FD
      case DBUS_TYPE_UNIX_FD:
#endif
503
	CHECK_NATNUM (object);
504
	{
505
	  dbus_uint32_t val = XFASTINT (object);
506 507
	  XD_DEBUG_MESSAGE ("%c %u", dtype, val);
	  if (!dbus_message_iter_append_basic (iter, dtype, &val))
508
	    XD_SIGNAL2 (build_string ("Unable to append argument"), object);
509 510
	  return;
	}
511

512
      case DBUS_TYPE_INT64:
513
	CHECK_NUMBER (object);
514 515 516 517
	{
	  dbus_int64_t val = XINT (object);
	  XD_DEBUG_MESSAGE ("%c %d", dtype, (int) val);
	  if (!dbus_message_iter_append_basic (iter, dtype, &val))
518
	    XD_SIGNAL2 (build_string ("Unable to append argument"), object);
519 520
	  return;
	}
521

522
      case DBUS_TYPE_UINT64:
523
	CHECK_NATNUM (object);
524
	{
525 526
	  dbus_uint64_t val = XFASTINT (object);
	  XD_DEBUG_MESSAGE ("%c %"pI"d", dtype, XFASTINT (object));
527
	  if (!dbus_message_iter_append_basic (iter, dtype, &val))
528
	    XD_SIGNAL2 (build_string ("Unable to append argument"), object);
529
	  return;
530
	}
531

532
      case DBUS_TYPE_DOUBLE:
533
	CHECK_FLOAT (object);
534 535 536 537 538 539 540
	{
	  double val = XFLOAT_DATA (object);
	  XD_DEBUG_MESSAGE ("%c %f", dtype, val);
	  if (!dbus_message_iter_append_basic (iter, dtype, &val))
	    XD_SIGNAL2 (build_string ("Unable to append argument"), object);
	  return;
	}
541 542 543 544

      case DBUS_TYPE_STRING:
      case DBUS_TYPE_OBJECT_PATH:
      case DBUS_TYPE_SIGNATURE:
545
	CHECK_STRING (object);
546
	{
547 548 549 550
	  /* We need to send a valid UTF-8 string.  We could encode `object'
	     but by not encoding it, we guarantee it's valid utf-8, even if
	     it contains eight-bit-bytes.  Of course, you can still send
	     manually-crafted junk by passing a unibyte string.  */
551
	  char *val = SSDATA (object);
552 553
	  XD_DEBUG_MESSAGE ("%c %s", dtype, val);
	  if (!dbus_message_iter_append_basic (iter, dtype, &val))
554
	    XD_SIGNAL2 (build_string ("Unable to append argument"), object);
555 556 557
	  return;
	}
      }
558 559 560 561 562 563

  else /* Compound types.  */
    {

      /* All compound types except array have a type symbol.  For
	 array, it is optional.  Skip it.  */
564
      if (!XD_BASIC_DBUS_TYPE (XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object))))
565 566 567 568 569 570
	object = XD_NEXT_VALUE (object);

      /* Open new subiteration.  */
      switch (dtype)
	{
	case DBUS_TYPE_ARRAY:
571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588
	  /* An array has only elements of the same type.  So it is
	     sufficient to check the first element's signature
	     only.  */

	  if (NILP (object))
	    /* If the array is empty, DBUS_TYPE_STRING is the default
	       element type.  */
	    strcpy (signature, DBUS_TYPE_STRING_AS_STRING);

	  else
	    /* If the element type is DBUS_TYPE_SIGNATURE, and this is
	       the only element, the value of this element is used as
	       the array's element signature.  */
	    if ((XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object))
		 == DBUS_TYPE_SIGNATURE)
		&& STRINGP (CAR_SAFE (XD_NEXT_VALUE (object)))
		&& NILP (CDR_SAFE (XD_NEXT_VALUE (object))))
	      {
589
		strcpy (signature, SSDATA (CAR_SAFE (XD_NEXT_VALUE (object))));
590 591 592 593 594 595 596 597 598 599 600 601
		object = CDR_SAFE (XD_NEXT_VALUE (object));
	      }

	    else
	      xd_signature (signature,
			    XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object)),
			    dtype, CAR_SAFE (XD_NEXT_VALUE (object)));

	  XD_DEBUG_MESSAGE ("%c %s %s", dtype, signature,
			    SDATA (format2 ("%s", object, Qnil)));
	  if (!dbus_message_iter_open_container (iter, dtype,
						 signature, &subiter))
602 603
	    XD_SIGNAL3 (build_string ("Cannot open container"),
			make_number (dtype), build_string (signature));
604 605
	  break;

606
	case DBUS_TYPE_VARIANT:
607 608 609 610
	  /* A variant has just one element.  */
	  xd_signature (signature, XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object)),
			dtype, CAR_SAFE (XD_NEXT_VALUE (object)));

611 612 613 614
	  XD_DEBUG_MESSAGE ("%c %s %s", dtype, signature,
			    SDATA (format2 ("%s", object, Qnil)));
	  if (!dbus_message_iter_open_container (iter, dtype,
						 signature, &subiter))
615 616
	    XD_SIGNAL3 (build_string ("Cannot open container"),
			make_number (dtype), build_string (signature));
617 618 619 620
	  break;

	case DBUS_TYPE_STRUCT:
	case DBUS_TYPE_DICT_ENTRY:
621
	  /* These containers do not require a signature.  */
622 623 624
	  XD_DEBUG_MESSAGE ("%c %s", dtype,
			    SDATA (format2 ("%s", object, Qnil)));
	  if (!dbus_message_iter_open_container (iter, dtype, NULL, &subiter))
625 626
	    XD_SIGNAL2 (build_string ("Cannot open container"),
			make_number (dtype));
627 628 629 630 631 632
	  break;
	}

      /* Loop over list elements.  */
      while (!NILP (object))
	{
633
	  dtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object));
634 635
	  object = XD_NEXT_VALUE (object);

636
	  xd_append_arg (dtype, CAR_SAFE (object), &subiter);
637

638
	  object = CDR_SAFE (object);
639 640
	}

641
      /* Close the subiteration.  */
642
      if (!dbus_message_iter_close_container (iter, &subiter))
643 644
	XD_SIGNAL2 (build_string ("Cannot close container"),
		    make_number (dtype));
645
    }
646 647 648 649
}

/* Retrieve C value from a DBusMessageIter structure ITER, and return
   a converted Lisp object.  The type DTYPE of the argument of the
650 651
   D-Bus message must be a valid DBusType.  Compound D-Bus types
   result always in a Lisp list.  */
652
static Lisp_Object
653
xd_retrieve_arg (unsigned int dtype, DBusMessageIter *iter)
654 655 656 657
{

  switch (dtype)
    {
658 659
    case DBUS_TYPE_BYTE:
      {
660
	unsigned int val;
661
	dbus_message_iter_get_basic (iter, &val);
662
	val = val & 0xFF;
663 664 665 666
	XD_DEBUG_MESSAGE ("%c %d", dtype, val);
	return make_number (val);
      }

667 668 669 670
    case DBUS_TYPE_BOOLEAN:
      {
	dbus_bool_t val;
	dbus_message_iter_get_basic (iter, &val);
671
	XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true");
672 673
	return (val == FALSE) ? Qnil : Qt;
      }
674

675
    case DBUS_TYPE_INT16:
676 677 678 679 680 681 682
      {
	dbus_int16_t val;
	dbus_message_iter_get_basic (iter, &val);
	XD_DEBUG_MESSAGE ("%c %d", dtype, val);
	return make_number (val);
      }

683 684 685 686 687 688 689 690
    case DBUS_TYPE_UINT16:
      {
	dbus_uint16_t val;
	dbus_message_iter_get_basic (iter, &val);
	XD_DEBUG_MESSAGE ("%c %d", dtype, val);
	return make_number (val);
      }

691
    case DBUS_TYPE_INT32:
692 693 694 695 696 697 698
      {
	dbus_int32_t val;
	dbus_message_iter_get_basic (iter, &val);
	XD_DEBUG_MESSAGE ("%c %d", dtype, val);
	return make_fixnum_or_float (val);
      }

699
    case DBUS_TYPE_UINT32:
700 701 702
#ifdef DBUS_TYPE_UNIX_FD
    case DBUS_TYPE_UNIX_FD:
#endif
703 704 705
      {
	dbus_uint32_t val;
	dbus_message_iter_get_basic (iter, &val);
706
	XD_DEBUG_MESSAGE ("%c %d", dtype, val);
707
	return make_fixnum_or_float (val);
708 709 710
      }

    case DBUS_TYPE_INT64:
711 712 713 714 715 716 717
      {
	dbus_int64_t val;
	dbus_message_iter_get_basic (iter, &val);
	XD_DEBUG_MESSAGE ("%c %d", dtype, (int) val);
	return make_fixnum_or_float (val);
      }

718 719 720 721
    case DBUS_TYPE_UINT64:
      {
	dbus_uint64_t val;
	dbus_message_iter_get_basic (iter, &val);
722
	XD_DEBUG_MESSAGE ("%c %d", dtype, (int) val);
723 724 725 726 727 728 729 730 731
	return make_fixnum_or_float (val);
      }

    case DBUS_TYPE_DOUBLE:
      {
	double val;
	dbus_message_iter_get_basic (iter, &val);
	XD_DEBUG_MESSAGE ("%c %f", dtype, val);
	return make_float (val);
732
      }
733

734 735
    case DBUS_TYPE_STRING:
    case DBUS_TYPE_OBJECT_PATH:
736
    case DBUS_TYPE_SIGNATURE:
737 738 739
      {
	char *val;
	dbus_message_iter_get_basic (iter, &val);
740
	XD_DEBUG_MESSAGE ("%c %s", dtype, val);
741 742
	return build_string (val);
      }
743

744 745 746 747 748 749 750 751 752
    case DBUS_TYPE_ARRAY:
    case DBUS_TYPE_VARIANT:
    case DBUS_TYPE_STRUCT:
    case DBUS_TYPE_DICT_ENTRY:
      {
	Lisp_Object result;
	struct gcpro gcpro1;
	DBusMessageIter subiter;
	int subtype;
753 754
	result = Qnil;
	GCPRO1 (result);
755 756 757 758 759 760 761
	dbus_message_iter_recurse (iter, &subiter);
	while ((subtype = dbus_message_iter_get_arg_type (&subiter))
	       != DBUS_TYPE_INVALID)
	  {
	    result = Fcons (xd_retrieve_arg (subtype, &subiter), result);
	    dbus_message_iter_next (&subiter);
	  }
762
	XD_DEBUG_MESSAGE ("%c %s", dtype, SDATA (format2 ("%s", result, Qnil)));
763 764
	RETURN_UNGCPRO (Fnreverse (result));
      }
765

766
    default:
767
      XD_DEBUG_MESSAGE ("DBusType '%c' not supported", dtype);
768 769 770 771
      return Qnil;
    }
}

772 773 774 775
/* Initialize D-Bus connection.  BUS is either a Lisp symbol, :system
   or :session, or a string denoting the bus address.  It tells which
   D-Bus to initialize.  If RAISE_ERROR is non-zero, signal an error
   when the connection cannot be initialized.  */
776
static DBusConnection *
777
xd_initialize (Lisp_Object bus, int raise_error)
778 779 780 781 782
{
  DBusConnection *connection;
  DBusError derror;

  /* Parameter check.  */
783 784 785 786 787 788 789 790 791 792
  if (!STRINGP (bus))
    {
      CHECK_SYMBOL (bus);
      if (!(EQ (bus, QCdbus_system_bus) || EQ (bus, QCdbus_session_bus)))
	{
	  if (raise_error)
	    XD_SIGNAL2 (build_string ("Wrong bus name"), bus);
	  else
	    return NULL;
	}
793

794 795 796 797 798 799 800 801 802 803
      /* We do not want to have an autolaunch for the session bus.  */
      if (EQ (bus, QCdbus_session_bus)
	  && getenv ("DBUS_SESSION_BUS_ADDRESS") == NULL)
	{
	  if (raise_error)
	    XD_SIGNAL2 (build_string ("No connection to bus"), bus);
	  else
	    return NULL;
	}
    }
804

805 806 807
  /* Open a connection to the bus.  */
  dbus_error_init (&derror);

808
  if (STRINGP (bus))
809
      connection = dbus_connection_open (SSDATA (bus), &derror);
810
  else
811 812 813 814
    if (EQ (bus, QCdbus_system_bus))
      connection = dbus_bus_get (DBUS_BUS_SYSTEM, &derror);
    else
      connection = dbus_bus_get (DBUS_BUS_SESSION, &derror);
815 816

  if (dbus_error_is_set (&derror))
817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842
    {
      if (raise_error)
	XD_ERROR (derror);
      else
	connection = NULL;
    }

  /* If it is not the system or session bus, we must register
     ourselves.  Otherwise, we have called dbus_bus_get, which has
     configured us to exit if the connection closes - we undo this
     setting.  */
  if (connection != NULL)
    {
      if (STRINGP (bus))
	dbus_bus_register (connection, &derror);
      else
	dbus_connection_set_exit_on_disconnect (connection, FALSE);
    }

  if (dbus_error_is_set (&derror))
    {
      if (raise_error)
	XD_ERROR (derror);
      else
	connection = NULL;
    }
843

844
  if (connection == NULL && raise_error)
845
    XD_SIGNAL2 (build_string ("No connection to bus"), bus);
846

847 848 849
  /* Cleanup.  */
  dbus_error_free (&derror);

850 851 852 853
  /* Return the result.  */
  return connection;
}

854 855 856
/* Return the file descriptor for WATCH, -1 if not found.  */
static int
xd_find_watch_fd (DBusWatch *watch)
857
{
858
#if HAVE_DBUS_WATCH_GET_UNIX_FD
859 860 861 862
  /* TODO: Reverse these on Win32, which prefers the opposite.  */
  int fd = dbus_watch_get_unix_fd (watch);
  if (fd == -1)
    fd = dbus_watch_get_socket (watch);
863
#else
864
  int fd = dbus_watch_get_fd (watch);
865
#endif
866 867
  return fd;
}
868

869 870 871
/* Prototype.  */
static void
xd_read_queued_messages (int fd, void *data, int for_read);
872

873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889
/* Start monitoring WATCH for possible I/O.  */
static dbus_bool_t
xd_add_watch (DBusWatch *watch, void *data)
{
  unsigned int flags = dbus_watch_get_flags (watch);
  int fd = xd_find_watch_fd (watch);

  XD_DEBUG_MESSAGE ("fd %d, write %d, enabled %d",
                    fd, flags & DBUS_WATCH_WRITABLE,
                    dbus_watch_get_enabled (watch));

  if (fd == -1)
    return FALSE;

  if (dbus_watch_get_enabled (watch))
    {
      if (flags & DBUS_WATCH_WRITABLE)
890
        add_write_fd (fd, xd_read_queued_messages, data);
891
      if (flags & DBUS_WATCH_READABLE)
892
        add_read_fd (fd, xd_read_queued_messages, data);
893
    }
894 895 896
  return TRUE;
}

897 898
/* Stop monitoring WATCH for possible I/O.
   DATA is the used bus, either a string or QCdbus_system_bus or
899
   QCdbus_session_bus.  */
900
static void
901
xd_remove_watch (DBusWatch *watch, void *data)
902
{
903