dbusbind.c 54.7 KB
Newer Older
1
/* Elisp bindings for D-Bus.
Paul Eggert's avatar
Paul Eggert committed
2
   Copyright (C) 2007-2017 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>
Paul Eggert's avatar
Paul Eggert committed
23
#include <stdlib.h>
24
#include <dbus/dbus.h>
25

26 27 28
#include "lisp.h"
#include "termhooks.h"
#include "keyboard.h"
29
#include "process.h"
30

31 32 33 34
#ifndef DBUS_NUM_MESSAGE_TYPES
#define DBUS_NUM_MESSAGE_TYPES 5
#endif

35 36 37 38

/* Some platforms define the symbol "interface", but we want to use it
 * as a variable name below.  */

39 40 41 42
#ifdef interface
#undef interface
#endif

43

44 45 46 47 48
/* Alist of D-Bus buses we are polling for messages.
   The key is the symbol or string of the bus, and the value is the
   connection address.  */
static Lisp_Object xd_registered_buses;

49
/* Whether we are reading a D-Bus event.  */
50
static bool xd_in_read_queued_messages = 0;
51

52 53 54 55

/* We use "xd_" and "XD_" as prefix for all internal symbols, because
   we don't want to poison other namespaces with "dbus_".  */

56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81
/* 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)

82
/* Raise a Lisp error from a D-Bus ERROR.  */
83
#define XD_ERROR(error)							\
84
  do {									\
85
    /* Remove the trailing newline.  */					\
86 87 88 89 90
    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);							\
91
  } while (0)
92 93

/* Macros for debugging.  In order to enable them, build with
94
   "make MYCPPFLAGS='-DDBUS_DEBUG'".  */
95
#ifdef DBUS_DEBUG
96 97 98 99 100 101 102
#define XD_DEBUG_MESSAGE(...)						\
  do {									\
    char s[1024];							\
    snprintf (s, sizeof s, __VA_ARGS__);				\
    if (!noninteractive)						\
      printf ("%s: %s\n", __func__, s);					\
    message ("%s: %s", __func__, s);					\
103
  } while (0)
104
#define XD_DEBUG_VALID_LISP_OBJECT_P(object)				\
105 106 107 108
  do {									\
    if (!valid_lisp_object_p (object))					\
      {									\
	XD_DEBUG_MESSAGE ("%d Assertion failure", __LINE__);		\
109
	XD_SIGNAL1 (build_string ("Assertion failure"));		\
110 111
      }									\
  } while (0)
112 113

#else /* !DBUS_DEBUG */
Paul Eggert's avatar
Paul Eggert committed
114
# define XD_DEBUG_MESSAGE(...)						\
115 116 117 118
  do {									\
    if (!NILP (Vdbus_debug))						\
      {									\
	char s[1024];							\
119
	snprintf (s, sizeof s, __VA_ARGS__);				\
120
	message ("%s: %s", __func__, s);				\
Michael Albinus's avatar
Michael Albinus committed
121
      }									\
122
  } while (0)
Paul Eggert's avatar
Paul Eggert committed
123
# define XD_DEBUG_VALID_LISP_OBJECT_P(object)
124 125
#endif

126
/* Check whether TYPE is a basic DBusType.  */
127 128 129 130
#ifdef HAVE_DBUS_TYPE_IS_VALID
#define XD_BASIC_DBUS_TYPE(type)					\
  (dbus_type_is_valid (type) && dbus_type_is_basic (type))
#else
131 132 133 134 135 136 137 138 139 140 141 142 143
#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)					\
144
   || (type ==  DBUS_TYPE_SIGNATURE)					\
145 146
   || (type ==  DBUS_TYPE_UNIX_FD))
#else
147 148 149 150 151 152 153 154 155 156 157 158 159
#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))
160
#endif
161
#endif
162

163
/* This was a macro.  On Solaris 2.11 it was said to compile for
Paul Eggert's avatar
Paul Eggert committed
164
   hours, when optimization is enabled.  So we have transferred it into
165
   a function.  */
166 167
/* Determine the DBusType of a given Lisp symbol.  OBJECT must be one
   of the predefined D-Bus type symbols.  */
168
static int
169
xd_symbol_to_dbus_type (Lisp_Object object)
170 171
{
  return
172 173 174 175 176 177 178 179 180 181 182 183
    (EQ (object, QCbyte) ? DBUS_TYPE_BYTE
     : EQ (object, QCboolean) ? DBUS_TYPE_BOOLEAN
     : EQ (object, QCint16) ? DBUS_TYPE_INT16
     : EQ (object, QCuint16) ? DBUS_TYPE_UINT16
     : EQ (object, QCint32) ? DBUS_TYPE_INT32
     : EQ (object, QCuint32) ? DBUS_TYPE_UINT32
     : EQ (object, QCint64) ? DBUS_TYPE_INT64
     : EQ (object, QCuint64) ? DBUS_TYPE_UINT64
     : EQ (object, QCdouble) ? DBUS_TYPE_DOUBLE
     : EQ (object, QCstring) ? DBUS_TYPE_STRING
     : EQ (object, QCobject_path) ? DBUS_TYPE_OBJECT_PATH
     : EQ (object, QCsignature) ? DBUS_TYPE_SIGNATURE
184
#ifdef DBUS_TYPE_UNIX_FD
185
     : EQ (object, QCunix_fd) ? DBUS_TYPE_UNIX_FD
186
#endif
187 188 189 190
     : EQ (object, QCarray) ? DBUS_TYPE_ARRAY
     : EQ (object, QCvariant) ? DBUS_TYPE_VARIANT
     : EQ (object, QCstruct) ? DBUS_TYPE_STRUCT
     : EQ (object, QCdict_entry) ? DBUS_TYPE_DICT_ENTRY
191 192
     : DBUS_TYPE_INVALID);
}
193 194 195

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

/* Determine the DBusType of a given Lisp OBJECT.  It is used to
199 200 201
   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.  */
202 203 204 205 206 207
#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				\
208
   : (XD_DBUS_TYPE_P (object)) ? xd_symbol_to_dbus_type (object)	\
209 210
   : (CONSP (object))							\
   ? ((XD_DBUS_TYPE_P (CAR_SAFE (object)))				\
211
      ? ((XD_BASIC_DBUS_TYPE (xd_symbol_to_dbus_type (CAR_SAFE (object)))) \
212
	 ? DBUS_TYPE_ARRAY						\
213
	 : xd_symbol_to_dbus_type (CAR_SAFE (object)))			\
214
      : DBUS_TYPE_ARRAY)						\
215 216 217
   : DBUS_TYPE_INVALID)

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

221 222 223 224 225 226 227 228 229 230 231 232 233 234 235
/* Transform the message type to its string representation for debug
   messages.  */
#define XD_MESSAGE_TYPE_TO_STRING(mtype)				\
  ((mtype == DBUS_MESSAGE_TYPE_INVALID)					\
  ? "DBUS_MESSAGE_TYPE_INVALID"						\
  : (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)				\
  ? "DBUS_MESSAGE_TYPE_METHOD_CALL"					\
  : (mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)				\
  ? "DBUS_MESSAGE_TYPE_METHOD_RETURN"					\
  : (mtype == DBUS_MESSAGE_TYPE_ERROR)					\
   ? "DBUS_MESSAGE_TYPE_ERROR"						\
   : "DBUS_MESSAGE_TYPE_SIGNAL")

/* Transform the object to its string representation for debug
   messages.  */
Paul Eggert's avatar
Paul Eggert committed
236 237 238 239 240 241
static char *
XD_OBJECT_TO_STRING (Lisp_Object object)
{
  AUTO_STRING (format, "%s");
  return SSDATA (CALLN (Fformat, format, object));
}
242 243 244

#define XD_DBUS_VALIDATE_BUS_ADDRESS(bus)				\
  do {									\
245
    char const *session_bus_address = getenv ("DBUS_SESSION_BUS_ADDRESS"); \
246 247 248 249 250 251 252 253 254 255 256
    if (STRINGP (bus))							\
      {									\
	DBusAddressEntry **entries;					\
	int len;							\
	DBusError derror;						\
	dbus_error_init (&derror);					\
	if (!dbus_parse_address (SSDATA (bus), &entries, &len, &derror)) \
	  XD_ERROR (derror);						\
	/* Cleanup.  */							\
	dbus_error_free (&derror);					\
	dbus_address_entries_free (entries);				\
257
	/* Canonicalize session bus address.  */			\
Michael Albinus's avatar
Michael Albinus committed
258 259 260
	if ((session_bus_address != NULL)				\
	    && (!NILP (Fstring_equal					\
		       (bus, build_string (session_bus_address)))))	\
261
	  bus = QCsession;						\
262 263 264 265 266
      }									\
									\
    else								\
      {									\
	CHECK_SYMBOL (bus);						\
267
	if (!(EQ (bus, QCsystem) || EQ (bus, QCsession)))		\
268 269
	  XD_SIGNAL2 (build_string ("Wrong bus name"), bus);		\
	/* We do not want to have an autolaunch for the session bus.  */ \
270
	if (EQ (bus, QCsession) && session_bus_address == NULL)		\
271 272 273 274
	  XD_SIGNAL2 (build_string ("No connection to bus"), bus);	\
      }									\
  } while (0)

275 276
#if (HAVE_DBUS_VALIDATE_BUS_NAME || HAVE_DBUS_VALIDATE_PATH		\
     || HAVE_DBUS_VALIDATE_INTERFACE || HAVE_DBUS_VALIDATE_MEMBER)
277 278 279 280 281 282 283 284 285 286 287 288 289
#define XD_DBUS_VALIDATE_OBJECT(object, func)				\
  do {									\
    if (!NILP (object))							\
      {									\
	DBusError derror;						\
	CHECK_STRING (object);						\
	dbus_error_init (&derror);					\
	if (!func (SSDATA (object), &derror))				\
	  XD_ERROR (derror);						\
	/* Cleanup.  */							\
	dbus_error_free (&derror);					\
      }									\
  } while (0)
290
#endif
291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322

#if HAVE_DBUS_VALIDATE_BUS_NAME
#define XD_DBUS_VALIDATE_BUS_NAME(bus_name)				\
  XD_DBUS_VALIDATE_OBJECT(bus_name, dbus_validate_bus_name);
#else
#define XD_DBUS_VALIDATE_BUS_NAME(bus_name)				\
  if (!NILP (bus_name)) CHECK_STRING (bus_name);
#endif

#if HAVE_DBUS_VALIDATE_PATH
#define XD_DBUS_VALIDATE_PATH(path)					\
  XD_DBUS_VALIDATE_OBJECT(path, dbus_validate_path);
#else
#define XD_DBUS_VALIDATE_PATH(path)					\
  if (!NILP (path)) CHECK_STRING (path);
#endif

#if HAVE_DBUS_VALIDATE_INTERFACE
#define XD_DBUS_VALIDATE_INTERFACE(interface)				\
  XD_DBUS_VALIDATE_OBJECT(interface, dbus_validate_interface);
#else
#define XD_DBUS_VALIDATE_INTERFACE(interface)				\
  if (!NILP (interface)) CHECK_STRING (interface);
#endif

#if HAVE_DBUS_VALIDATE_MEMBER
#define XD_DBUS_VALIDATE_MEMBER(member)					\
  XD_DBUS_VALIDATE_OBJECT(member, dbus_validate_member);
#else
#define XD_DBUS_VALIDATE_MEMBER(member)					\
  if (!NILP (member)) CHECK_STRING (member);
#endif
323

Paul Eggert's avatar
Paul Eggert committed
324
/* Append to SIGNATURE a copy of X, making sure SIGNATURE does
325 326
   not become too long.  */
static void
327
xd_signature_cat (char *signature, char const *x)
328 329 330 331 332
{
  ptrdiff_t siglen = strlen (signature);
  ptrdiff_t xlen = strlen (x);
  if (DBUS_MAXIMUM_SIGNATURE_LENGTH - xlen <= siglen)
    string_overflow ();
Paul Eggert's avatar
Paul Eggert committed
333
  strcpy (signature + siglen, x);
334 335
}

336 337 338 339 340 341 342
/* 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.  */
343
static void
344
xd_signature (char *signature, int dtype, int parent_type, Lisp_Object object)
345
{
346
  int subtype;
347
  Lisp_Object elt;
348
  char const *subsig;
349
  int subsiglen;
350 351 352
  char x[DBUS_MAXIMUM_SIGNATURE_LENGTH];

  elt = object;
353 354 355

  switch (dtype)
    {
356 357 358
    case DBUS_TYPE_BYTE:
    case DBUS_TYPE_UINT16:
      CHECK_NATNUM (object);
359
      sprintf (signature, "%c", dtype);
360
      break;
361

362
    case DBUS_TYPE_BOOLEAN:
363 364
      if (!EQ (object, Qt) && !EQ (object, Qnil))
	wrong_type_argument (intern ("booleanp"), object);
365
      sprintf (signature, "%c", dtype);
366
      break;
367

368 369
    case DBUS_TYPE_INT16:
      CHECK_NUMBER (object);
370
      sprintf (signature, "%c", dtype);
371
      break;
372

373 374 375 376 377 378 379
    case DBUS_TYPE_UINT32:
    case DBUS_TYPE_UINT64:
#ifdef DBUS_TYPE_UNIX_FD
    case DBUS_TYPE_UNIX_FD:
#endif
    case DBUS_TYPE_INT32:
    case DBUS_TYPE_INT64:
380
    case DBUS_TYPE_DOUBLE:
381
      CHECK_NUMBER_OR_FLOAT (object);
382
      sprintf (signature, "%c", dtype);
383
      break;
384

385
    case DBUS_TYPE_STRING:
386 387 388
    case DBUS_TYPE_OBJECT_PATH:
    case DBUS_TYPE_SIGNATURE:
      CHECK_STRING (object);
389
      sprintf (signature, "%c", dtype);
390
      break;
391

392
    case DBUS_TYPE_ARRAY:
393
      /* Check that all list elements have the same D-Bus type.  For
394 395
	 complex element types, we just check the container type, not
	 the whole element's signature.  */
396
      CHECK_CONS (object);
397

398
      /* Type symbol is optional.  */
399
      if (EQ (QCarray, CAR_SAFE (elt)))
400
	elt = XD_NEXT_VALUE (elt);
401 402 403 404 405 406

      /* If the array is empty, DBUS_TYPE_STRING is the default
	 element type.  */
      if (NILP (elt))
	{
	  subtype = DBUS_TYPE_STRING;
407
	  subsig = DBUS_TYPE_STRING_AS_STRING;
408 409 410 411 412
	}
      else
	{
	  subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
	  xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
413
	  subsig = x;
414 415 416
	}

      /* If the element type is DBUS_TYPE_SIGNATURE, and this is the
417 418
	 only element, the value of this element is used as the
	 array's element signature.  */
419 420 421
      if ((subtype == DBUS_TYPE_SIGNATURE)
	  && STRINGP (CAR_SAFE (XD_NEXT_VALUE (elt)))
	  && NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
422
	subsig = SSDATA (CAR_SAFE (XD_NEXT_VALUE (elt)));
423 424 425

      while (!NILP (elt))
	{
426 427 428
	  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));
429 430
	}

431 432 433
      subsiglen = snprintf (signature, DBUS_MAXIMUM_SIGNATURE_LENGTH,
			    "%c%s", dtype, subsig);
      if (! (0 <= subsiglen && subsiglen < DBUS_MAXIMUM_SIGNATURE_LENGTH))
434
	string_overflow ();
435
      break;
436

437
    case DBUS_TYPE_VARIANT:
438
      /* Check that there is exactly one list element.  */
439
      CHECK_CONS (object);
440 441

      elt = XD_NEXT_VALUE (elt);
442 443
      subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
      xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
444

445
      if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
446
	wrong_type_argument (intern ("D-Bus"),
447
			     CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt))));
448

449
      sprintf (signature, "%c", dtype);
450
      break;
451

452
    case DBUS_TYPE_STRUCT:
453 454
      /* A struct list might contain any number of elements with
	 different types.  No further check needed.  */
455 456 457 458 459 460 461 462 463
      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))
	{
464 465
	  subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
	  xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
466
	  xd_signature_cat (signature, x);
467
	  elt = CDR_SAFE (XD_NEXT_VALUE (elt));
468
	}
469
      xd_signature_cat (signature, DBUS_STRUCT_END_CHAR_AS_STRING);
470 471
      break;

472
    case DBUS_TYPE_DICT_ENTRY:
473 474 475
      /* 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.  */
476
      CHECK_CONS (object);
477

478
      /* Check the parent object type.  */
479 480
      if (parent_type != DBUS_TYPE_ARRAY)
	wrong_type_argument (intern ("D-Bus"), object);
481

482 483 484
      /* Compose the signature from the elements.  It is enclosed by
	 curly braces.  */
      sprintf (signature, "%c", DBUS_DICT_ENTRY_BEGIN_CHAR);
485

486 487
      /* First element.  */
      elt = XD_NEXT_VALUE (elt);
488 489
      subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
      xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
490
      xd_signature_cat (signature, x);
491

492
      if (!XD_BASIC_DBUS_TYPE (subtype))
493
	wrong_type_argument (intern ("D-Bus"), CAR_SAFE (XD_NEXT_VALUE (elt)));
494

495
      /* Second element.  */
496 497 498
      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)));
499
      xd_signature_cat (signature, x);
500

501
      if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
502
	wrong_type_argument (intern ("D-Bus"),
503
			     CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt))));
504

505
      /* Closing signature.  */
506
      xd_signature_cat (signature, DBUS_DICT_ENTRY_END_CHAR_AS_STRING);
507
      break;
508

509 510
    default:
      wrong_type_argument (intern ("D-Bus"), object);
511 512
    }

513 514
  XD_DEBUG_MESSAGE ("%s", signature);
}
515

Paul Eggert's avatar
Paul Eggert committed
516 517
/* Convert X to a signed integer with bounds LO and HI.  */
static intmax_t
518
xd_extract_signed (Lisp_Object x, intmax_t lo, intmax_t hi)
Paul Eggert's avatar
Paul Eggert committed
519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535
{
  CHECK_NUMBER_OR_FLOAT (x);
  if (INTEGERP (x))
    {
      if (lo <= XINT (x) && XINT (x) <= hi)
	return XINT (x);
    }
  else
    {
      double d = XFLOAT_DATA (x);
      if (lo <= d && d <= hi)
	{
	  intmax_t n = d;
	  if (n == d)
	    return n;
	}
    }
536 537 538 539 540 541
  if (xd_in_read_queued_messages)
    Fthrow (Qdbus_error, Qnil);
  else
    args_out_of_range_3 (x,
			 make_fixnum_or_float (lo),
			 make_fixnum_or_float (hi));
Paul Eggert's avatar
Paul Eggert committed
542 543 544 545
}

/* Convert X to an unsigned integer with bounds 0 and HI.  */
static uintmax_t
546
xd_extract_unsigned (Lisp_Object x, uintmax_t hi)
Paul Eggert's avatar
Paul Eggert committed
547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563
{
  CHECK_NUMBER_OR_FLOAT (x);
  if (INTEGERP (x))
    {
      if (0 <= XINT (x) && XINT (x) <= hi)
	return XINT (x);
    }
  else
    {
      double d = XFLOAT_DATA (x);
      if (0 <= d && d <= hi)
	{
	  uintmax_t n = d;
	  if (n == d)
	    return n;
	}
    }
564 565 566 567
  if (xd_in_read_queued_messages)
    Fthrow (Qdbus_error, Qnil);
  else
    args_out_of_range_3 (x, make_number (0), make_fixnum_or_float (hi));
Paul Eggert's avatar
Paul Eggert committed
568 569
}

570 571 572 573 574
/* 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.  */
575
static void
576
xd_append_arg (int dtype, Lisp_Object object, DBusMessageIter *iter)
577 578 579 580 581
{
  char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
  DBusMessageIter subiter;

  if (XD_BASIC_DBUS_TYPE (dtype))
582 583 584
    switch (dtype)
      {
      case DBUS_TYPE_BYTE:
585
	CHECK_NATNUM (object);
586
	{
587
	  unsigned char val = XFASTINT (object) & 0xFF;
588
	  XD_DEBUG_MESSAGE ("%c %u", dtype, val);
589
	  if (!dbus_message_iter_append_basic (iter, dtype, &val))
590
	    XD_SIGNAL2 (build_string ("Unable to append argument"), object);
591 592
	  return;
	}
593

594 595 596 597 598
      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))
599
	    XD_SIGNAL2 (build_string ("Unable to append argument"), object);
600 601
	  return;
	}
602

603 604
      case DBUS_TYPE_INT16:
	{
605 606 607 608
	  dbus_int16_t val =
	    xd_extract_signed (object,
			       TYPE_MINIMUM (dbus_int16_t),
			       TYPE_MAXIMUM (dbus_int16_t));
609 610
	  int pval = val;
	  XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
611
	  if (!dbus_message_iter_append_basic (iter, dtype, &val))
612
	    XD_SIGNAL2 (build_string ("Unable to append argument"), object);
613 614
	  return;
	}
615

616 617
      case DBUS_TYPE_UINT16:
	{
618 619 620
	  dbus_uint16_t val =
	    xd_extract_unsigned (object,
				 TYPE_MAXIMUM (dbus_uint16_t));
621 622
	  unsigned int pval = val;
	  XD_DEBUG_MESSAGE ("%c %u", dtype, pval);
623
	  if (!dbus_message_iter_append_basic (iter, dtype, &val))
624
	    XD_SIGNAL2 (build_string ("Unable to append argument"), object);
625 626
	  return;
	}
627

628 629
      case DBUS_TYPE_INT32:
	{
630 631 632 633
	  dbus_int32_t val =
	    xd_extract_signed (object,
			       TYPE_MINIMUM (dbus_int32_t),
			       TYPE_MAXIMUM (dbus_int32_t));
634 635
	  int pval = val;
	  XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
636
	  if (!dbus_message_iter_append_basic (iter, dtype, &val))
637
	    XD_SIGNAL2 (build_string ("Unable to append argument"), object);
638 639
	  return;
	}
640

641
      case DBUS_TYPE_UINT32:
642 643 644
#ifdef DBUS_TYPE_UNIX_FD
      case DBUS_TYPE_UNIX_FD:
#endif
645
	{
646 647 648
	  dbus_uint32_t val =
	    xd_extract_unsigned (object,
				 TYPE_MAXIMUM (dbus_uint32_t));
649 650
	  unsigned int pval = val;
	  XD_DEBUG_MESSAGE ("%c %u", dtype, pval);
651
	  if (!dbus_message_iter_append_basic (iter, dtype, &val))
652
	    XD_SIGNAL2 (build_string ("Unable to append argument"), object);
653 654
	  return;
	}
655

656 657
      case DBUS_TYPE_INT64:
	{
658 659 660 661
	  dbus_int64_t val =
	    xd_extract_signed (object,
			       TYPE_MINIMUM (dbus_int64_t),
			       TYPE_MAXIMUM (dbus_int64_t));
662 663
	  printmax_t pval = val;
	  XD_DEBUG_MESSAGE ("%c %"pMd, dtype, pval);
664
	  if (!dbus_message_iter_append_basic (iter, dtype, &val))
665
	    XD_SIGNAL2 (build_string ("Unable to append argument"), object);
666 667
	  return;
	}
668

669 670
      case DBUS_TYPE_UINT64:
	{
671 672 673
	  dbus_uint64_t val =
	    xd_extract_unsigned (object,
				 TYPE_MAXIMUM (dbus_uint64_t));
674 675
	  uprintmax_t pval = val;
	  XD_DEBUG_MESSAGE ("%c %"pMu, dtype, pval);
676
	  if (!dbus_message_iter_append_basic (iter, dtype, &val))
677
	    XD_SIGNAL2 (build_string ("Unable to append argument"), object);
678
	  return;
679
	}
680

681
      case DBUS_TYPE_DOUBLE:
682
	{
683
	  double val = extract_float (object);
684 685 686 687 688
	  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;
	}
689 690 691 692

      case DBUS_TYPE_STRING:
      case DBUS_TYPE_OBJECT_PATH:
      case DBUS_TYPE_SIGNATURE:
693
	CHECK_STRING (object);
694
	{
695 696 697 698
	  /* 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.  */
699
	  char *val = SSDATA (object);
700 701
	  XD_DEBUG_MESSAGE ("%c %s", dtype, val);
	  if (!dbus_message_iter_append_basic (iter, dtype, &val))
702
	    XD_SIGNAL2 (build_string ("Unable to append argument"), object);
703 704 705
	  return;
	}
      }
706 707 708 709 710 711

  else /* Compound types.  */
    {

      /* All compound types except array have a type symbol.  For
	 array, it is optional.  Skip it.  */
712
      if (!XD_BASIC_DBUS_TYPE (XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object))))
713 714 715 716 717 718
	object = XD_NEXT_VALUE (object);

      /* Open new subiteration.  */
      switch (dtype)
	{
	case DBUS_TYPE_ARRAY:
719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736
	  /* 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))))
	      {
737
		lispstpcpy (signature, CAR_SAFE (XD_NEXT_VALUE (object)));
738 739 740 741 742 743 744 745 746
		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,
747
			    XD_OBJECT_TO_STRING (object));
748 749
	  if (!dbus_message_iter_open_container (iter, dtype,
						 signature, &subiter))
750 751
	    XD_SIGNAL3 (build_string ("Cannot open container"),
			make_number (dtype), build_string (signature));
752 753
	  break;

754
	case DBUS_TYPE_VARIANT:
755 756 757 758
	  /* A variant has just one element.  */
	  xd_signature (signature, XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object)),
			dtype, CAR_SAFE (XD_NEXT_VALUE (object)));

759
	  XD_DEBUG_MESSAGE ("%c %s %s", dtype, signature,
760
			    XD_OBJECT_TO_STRING (object));
761 762
	  if (!dbus_message_iter_open_container (iter, dtype,
						 signature, &subiter))
763 764
	    XD_SIGNAL3 (build_string ("Cannot open container"),
			make_number (dtype), build_string (signature));
765 766 767 768
	  break;

	case DBUS_TYPE_STRUCT:
	case DBUS_TYPE_DICT_ENTRY:
769
	  /* These containers do not require a signature.  */
770
	  XD_DEBUG_MESSAGE ("%c %s", dtype, XD_OBJECT_TO_STRING (object));
771
	  if (!dbus_message_iter_open_container (iter, dtype, NULL, &subiter))
772 773
	    XD_SIGNAL2 (build_string ("Cannot open container"),
			make_number (dtype));
774 775 776 777 778 779
	  break;
	}

      /* Loop over list elements.  */
      while (!NILP (object))
	{
780
	  dtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object));
781 782
	  object = XD_NEXT_VALUE (object);

783
	  xd_append_arg (dtype, CAR_SAFE (object), &subiter);
784

785
	  object = CDR_SAFE (object);
786 787
	}

788
      /* Close the subiteration.  */
789
      if (!dbus_message_iter_close_container (iter, &subiter))
790 791
	XD_SIGNAL2 (build_string ("Cannot close container"),
		    make_number (dtype));
792
    }
793 794 795 796
}

/* Retrieve C value from a DBusMessageIter structure ITER, and return
   a converted Lisp object.  The type DTYPE of the argument of the
797 798
   D-Bus message must be a valid DBusType.  Compound D-Bus types
   result always in a Lisp list.  */
799
static Lisp_Object
800
xd_retrieve_arg (int dtype, DBusMessageIter *iter)
801 802 803 804
{

  switch (dtype)
    {
805 806
    case DBUS_TYPE_BYTE:
      {
807
	unsigned int val;
808
	dbus_message_iter_get_basic (iter, &val);
809
	val = val & 0xFF;
810
	XD_DEBUG_MESSAGE ("%c %u", dtype, val);
811 812 813
	return make_number (val);
      }

814 815 816 817
    case DBUS_TYPE_BOOLEAN:
      {
	dbus_bool_t val;
	dbus_message_iter_get_basic (iter, &val);
818
	XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true");
819 820
	return (val == FALSE) ? Qnil : Qt;
      }
821

822
    case DBUS_TYPE_INT16:
823 824
      {
	dbus_int16_t val;
825
	int pval;
826
	dbus_message_iter_get_basic (iter, &val);
827 828
	pval = val;
	XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
829 830 831
	return make_number (val);
      }

832 833 834
    case DBUS_TYPE_UINT16:
      {
	dbus_uint16_t val;
835
	int pval;
836
	dbus_message_iter_get_basic (iter, &val);
837 838
	pval = val;
	XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
839 840 841
	return make_number (val);
      }

842
    case DBUS_TYPE_INT32:
843 844
      {
	dbus_int32_t val;
845
	int pval;
846
	dbus_message_iter_get_basic (iter, &val);
847 848
	pval = val;
	XD_DEBUG_MESSAGE ("%c %d", dtype, pval);
849 850 851
	return make_fixnum_or_float (val);
      }

852
    case DBUS_TYPE_UINT32:
853 854 855
#ifdef DBUS_TYPE_UNIX_FD
    case DBUS_TYPE_UNIX_FD:
#endif
856 857
      {
	dbus_uint32_t val;
858
	unsigned int pval;
859
	dbus_message_iter_get_basic (iter, &val);
860 861
	pval = val;
	XD_DEBUG_MESSAGE ("%c %u", dtype, pval);
862
	return make_fixnum_or_float (val);
863 864 865
      }

    case DBUS_TYPE_INT64:
866 867
      {
	dbus_int64_t val;
868
	printmax_t pval;
869
	dbus_message_iter_get_basic (iter, &val);
870 871
	pval = val;
	XD_DEBUG_MESSAGE ("%c %"pMd, dtype, pval);
872 873 874
	return make_fixnum_or_float (val);
      }

875 876 877
    case DBUS_TYPE_UINT64:
      {
	dbus_uint64_t val;
878
	uprintmax_t pval;
879
	dbus_message_iter_get_basic (iter, &val);
880
	pval = val;
881
	XD_DEBUG_MESSAGE ("%c %"pMu, dtype, pval);
882 883 884 885 886 887 888 889 890
	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);
891
      }
892

893 894
    case DBUS_TYPE_STRING:
    case DBUS_TYPE_OBJECT_PATH:
895
    case DBUS_TYPE_SIGNATURE:
896 897 898
      {
	char *val;
	dbus_message_iter_get_basic (iter, &val);
899
	XD_DEBUG_MESSAGE ("%c %s", dtype