dbusbind.c 54.6 KB
Newer Older
1
/* Elisp bindings for D-Bus.
Paul Eggert's avatar
Paul Eggert committed
2
   Copyright (C) 2007-2019 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 <https://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
#define XD_OBJECT_TO_DBUS_TYPE(object)					\
Paul Eggert's avatar
Paul Eggert committed
203
  ((EQ (object, Qt) || NILP (object)) ? DBUS_TYPE_BOOLEAN		\
204 205
   : (FIXNATP (object)) ? DBUS_TYPE_UINT32				\
   : (FIXNUMP (object)) ? DBUS_TYPE_INT32				\
206 207
   : (FLOATP (object)) ? DBUS_TYPE_DOUBLE				\
   : (STRINGP (object)) ? DBUS_TYPE_STRING				\
208
   : (XD_DBUS_TYPE_P (object)) ? xd_symbol_to_dbus_type (object)	\
209
   : (CONSP (object))							\
210 211
   ? ((XD_DBUS_TYPE_P (XCAR (object)))					\
      ? ((XD_BASIC_DBUS_TYPE (xd_symbol_to_dbus_type (XCAR (object))))	\
212
	 ? DBUS_TYPE_ARRAY						\
213
	 : xd_symbol_to_dbus_type (XCAR (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
static char *
XD_OBJECT_TO_STRING (Lisp_Object object)
{
  AUTO_STRING (format, "%s");
240
  return SSDATA (CALLN (Fformat, format, object));
Paul Eggert's avatar
Paul Eggert committed
241
}
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 350 351
  char x[DBUS_MAXIMUM_SIGNATURE_LENGTH];

  elt = object;
352 353 354

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

361
    case DBUS_TYPE_BOOLEAN:
Paul Eggert's avatar
Paul Eggert committed
362
      if (!EQ (object, Qt) && !NILP (object))
363
	wrong_type_argument (intern ("booleanp"), object);
364
      sprintf (signature, "%c", dtype);
365
      break;
366

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

372 373 374 375 376 377 378
    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:
379
    case DBUS_TYPE_DOUBLE:
380
      CHECK_NUMBER (object);
381
      sprintf (signature, "%c", dtype);
382
      break;
383

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

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

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

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

      /* If the element type is DBUS_TYPE_SIGNATURE, and this is the
416 417
	 only element, the value of this element is used as the
	 array's element signature.  */
418 419 420 421 422 423
      if (subtype == DBUS_TYPE_SIGNATURE)
	{
	  Lisp_Object elt1 = XD_NEXT_VALUE (elt);
	  if (CONSP (elt1) && STRINGP (XCAR (elt1)) && NILP (XCDR (elt1)))
	    subsig = SSDATA (XCAR (elt1));
	}
424 425 426

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

432 433 434
      signature[0] = dtype;
      signature[1] = '\0';
      xd_signature_cat (signature, subsig);
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
  CHECK_NUMBER (x);
521
  if (INTEGERP (x))
Paul Eggert's avatar
Paul Eggert committed
522
    {
523 524 525
      intmax_t i;
      if (integer_to_intmax (x, &i) && lo <= i && i <= hi)
	return i;
Paul Eggert's avatar
Paul Eggert committed
526
    }
527
  else
Paul Eggert's avatar
Paul Eggert committed
528 529
    {
      double d = XFLOAT_DATA (x);
Paul Eggert's avatar
Paul Eggert committed
530
      if (lo <= d && d < 1.0 + hi)
Paul Eggert's avatar
Paul Eggert committed
531 532 533 534 535 536
	{
	  intmax_t n = d;
	  if (n == d)
	    return n;
	}
    }
537

538 539 540
  if (xd_in_read_queued_messages)
    Fthrow (Qdbus_error, Qnil);
  else
541
    args_out_of_range_3 (x, INT_TO_INTEGER (lo), INT_TO_INTEGER (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
  CHECK_NUMBER (x);
549
  if (INTEGERP (x))
Paul Eggert's avatar
Paul Eggert committed
550
    {
551 552 553
      uintmax_t i;
      if (integer_to_uintmax (x, &i) && i <= hi)
	return i;
Paul Eggert's avatar
Paul Eggert committed
554
    }
555
  else
Paul Eggert's avatar
Paul Eggert committed
556 557
    {
      double d = XFLOAT_DATA (x);
Paul Eggert's avatar
Paul Eggert committed
558
      if (0 <= d && d < 1.0 + hi)
Paul Eggert's avatar
Paul Eggert committed
559 560 561 562 563 564
	{
	  uintmax_t n = d;
	  if (n == d)
	    return n;
	}
    }
565

566 567 568
  if (xd_in_read_queued_messages)
    Fthrow (Qdbus_error, Qnil);
  else
569
    args_out_of_range_3 (x, make_fixnum (0), INT_TO_INTEGER (hi));
Paul Eggert's avatar
Paul Eggert committed
570 571
}

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

  if (XD_BASIC_DBUS_TYPE (dtype))
584 585 586
    switch (dtype)
      {
      case DBUS_TYPE_BYTE:
587
	CHECK_FIXNAT (object);
588
	{
Tom Tromey's avatar
Tom Tromey committed
589
	  unsigned char val = XFIXNAT (object) & 0xFF;
590
	  XD_DEBUG_MESSAGE ("%c %u", dtype, val);
591
	  if (!dbus_message_iter_append_basic (iter, dtype, &val))
592
	    XD_SIGNAL2 (build_string ("Unable to append argument"), object);
593 594
	  return;
	}
595

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

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

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

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

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

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

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

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

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

  else /* Compound types.  */
    {

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

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

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

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

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

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

785
	  xd_append_arg (dtype, CAR_SAFE (object), &subiter);
786

787
	  object = CDR_SAFE (object);
788 789
	}

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

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

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

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

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

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

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

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

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

877 878 879
    case DBUS_TYPE_UINT64:
      {
	dbus_uint64_t val;
880
	uprintmax_t pval;
881
	dbus_message_iter_get_basic (iter, &val);
882
	pval = val;
883
	XD_DEBUG_MESSAGE ("%c %"pMu, dtype, pval);
884
	return INT_TO_INTEGER (val);
885 886 887 888 889 890 891 892
      }

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

895 896
    case DBUS_TYPE_STRING:
    case DBUS_TYPE_OBJECT_PATH:
897
    case DBUS_TYPE_SIGNATURE:
898 899 900
      {
	char *val;
	dbus_message_iter_get_basic (iter, &val);
901
	XD_DEBUG_MESSAGE ("%c %s", dtype, val);
902 903
	return build_string (val);
      }
904

905 906 907 908 909 910 911 912
    case DBUS_TYPE_ARRAY:
    case DBUS_TYPE_VARIANT:
    case DBUS_TYPE_STRUCT:
    case DBUS_TYPE_DICT_ENTRY:
      {
	Lisp_Object result;
	DBusMessageIter subiter;
	int subtype;
913
	result = Qnil;
914 915 916 917 918 919 920
	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);
	  }
921
	XD_DEBUG_MESSAGE ("%c %s", dtype, XD_OBJECT_TO_STRING (result));
922
	return Fnreverse (result