src/dbusbind.c

   1 /* Elisp bindings for D-Bus.
   2    Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
   3
   4 This file is part of GNU Emacs.
   5
   6 GNU Emacs is free software: you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation, either version 3 of the License, or
   9 (at your option) any later version.
  10
  11 GNU Emacs is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.  */
  18
  19 #include <config.h>
  20
  21 #ifdef HAVE_DBUS
  22 #include <stdlib.h>
  23 #include <stdio.h>
  24 #include <dbus/dbus.h>
  25 #include <setjmp.h>
  26 #include "lisp.h"
  27 #include "frame.h"
  28 #include "termhooks.h"
  29 #include "keyboard.h"
  30 #include "process.h"
  31
  32 \f
  33 /* Subroutines.  */
  34 Lisp_Object Qdbus_init_bus;
  35 Lisp_Object Qdbus_close_bus;
  36 Lisp_Object Qdbus_get_unique_name;
  37 Lisp_Object Qdbus_call_method;
  38 Lisp_Object Qdbus_call_method_asynchronously;
  39 Lisp_Object Qdbus_method_return_internal;
  40 Lisp_Object Qdbus_method_error_internal;
  41 Lisp_Object Qdbus_send_signal;
  42 Lisp_Object Qdbus_register_signal;
  43 Lisp_Object Qdbus_register_method;
  44
  45 /* D-Bus error symbol.  */
  46 Lisp_Object Qdbus_error;
  47
  48 /* Lisp symbols of the system and session buses.  */
  49 Lisp_Object QCdbus_system_bus, QCdbus_session_bus;
  50
  51 /* Lisp symbol for method call timeout.  */
  52 Lisp_Object QCdbus_timeout;
  53
  54 /* Lisp symbols of D-Bus types.  */
  55 Lisp_Object QCdbus_type_byte, QCdbus_type_boolean;
  56 Lisp_Object QCdbus_type_int16, QCdbus_type_uint16;
  57 Lisp_Object QCdbus_type_int32, QCdbus_type_uint32;
  58 Lisp_Object QCdbus_type_int64, QCdbus_type_uint64;
  59 Lisp_Object QCdbus_type_double, QCdbus_type_string;
  60 Lisp_Object QCdbus_type_object_path, QCdbus_type_signature;
  61 Lisp_Object QCdbus_type_array, QCdbus_type_variant;
  62 Lisp_Object QCdbus_type_struct, QCdbus_type_dict_entry;
  63
  64 /* Registered buses.  */
  65 Lisp_Object Vdbus_registered_buses;
  66
  67 /* Hash table which keeps function definitions.  */
  68 Lisp_Object Vdbus_registered_objects_table;
  69
  70 /* Whether to debug D-Bus.  */
  71 Lisp_Object Vdbus_debug;
  72
  73 /* Whether we are reading a D-Bus event.  */
  74 int xd_in_read_queued_messages = 0;
  75
  76 \f
  77 /* We use "xd_" and "XD_" as prefix for all internal symbols, because
  78    we don't want to poison other namespaces with "dbus_".  */
  79
  80 /* Raise a signal.  If we are reading events, we cannot signal; we
  81    throw to xd_read_queued_messages then.  */
  82 #define XD_SIGNAL1(arg)                                                 \
  83   do {                                                                  \
  84     if (xd_in_read_queued_messages)                                     \
  85       Fthrow (Qdbus_error, Qnil);                                       \
  86     else                                                                \
  87       xsignal1 (Qdbus_error, arg);                                      \
  88   } while (0)
  89
  90 #define XD_SIGNAL2(arg1, arg2)                                          \
  91   do {                                                                  \
  92     if (xd_in_read_queued_messages)                                     \
  93       Fthrow (Qdbus_error, Qnil);                                       \
  94     else                                                                \
  95       xsignal2 (Qdbus_error, arg1, arg2);                               \
  96   } while (0)
  97
  98 #define XD_SIGNAL3(arg1, arg2, arg3)                                    \
  99   do {                                                                  \
 100     if (xd_in_read_queued_messages)                                     \
 101       Fthrow (Qdbus_error, Qnil);                                       \
 102     else                                                                \
 103       xsignal3 (Qdbus_error, arg1, arg2, arg3);                         \
 104   } while (0)
 105
 106 /* Raise a Lisp error from a D-Bus ERROR.  */
 107 #define XD_ERROR(error)                                                 \
 108   do {                                                                  \
 109     char s[1024];                                                       \
 110     strncpy (s, error.message, 1023);                                   \
 111     dbus_error_free (&error);                                           \
 112     /* Remove the trailing newline.  */                                 \
 113     if (strchr (s, '\n') != NULL)                                       \
 114       s[strlen (s) - 1] = '\0';                                         \
 115     XD_SIGNAL1 (build_string (s));                                      \
 116   } while (0)
 117
 118 /* Macros for debugging.  In order to enable them, build with
 119    "MYCPPFLAGS='-DDBUS_DEBUG -Wall' make".  */
 120 #ifdef DBUS_DEBUG
 121 #define XD_DEBUG_MESSAGE(...)           \
 122   do {                                  \
 123     char s[1024];                       \
 124     snprintf (s, 1023, __VA_ARGS__);    \
 125     printf ("%s: %s\n", __func__, s);   \
 126     message ("%s: %s", __func__, s);    \
 127   } while (0)
 128 #define XD_DEBUG_VALID_LISP_OBJECT_P(object)                            \
 129   do {                                                                  \
 130     if (!valid_lisp_object_p (object))                                  \
 131       {                                                                 \
 132         XD_DEBUG_MESSAGE ("%d Assertion failure", __LINE__);            \
 133         XD_SIGNAL1 (build_string ("Assertion failure"));                \
 134       }                                                                 \
 135   } while (0)
 136
 137 #else /* !DBUS_DEBUG */
 138 #define XD_DEBUG_MESSAGE(...)                                           \
 139   do {                                                                  \
 140     if (!NILP (Vdbus_debug))                                            \
 141       {                                                                 \
 142         char s[1024];                                                   \
 143         snprintf (s, 1023, __VA_ARGS__);                                \
 144         message ("%s: %s", __func__, s);                                \
 145       }                                                                 \
 146   } while (0)
 147 #define XD_DEBUG_VALID_LISP_OBJECT_P(object)
 148 #endif
 149
 150 /* Check whether TYPE is a basic DBusType.  */
 151 #define XD_BASIC_DBUS_TYPE(type)                                        \
 152   ((type ==  DBUS_TYPE_BYTE)                                            \
 153    || (type ==  DBUS_TYPE_BOOLEAN)                                      \
 154    || (type ==  DBUS_TYPE_INT16)                                        \
 155    || (type ==  DBUS_TYPE_UINT16)                                       \
 156    || (type ==  DBUS_TYPE_INT32)                                        \
 157    || (type ==  DBUS_TYPE_UINT32)                                       \
 158    || (type ==  DBUS_TYPE_INT64)                                        \
 159    || (type ==  DBUS_TYPE_UINT64)                                       \
 160    || (type ==  DBUS_TYPE_DOUBLE)                                       \
 161    || (type ==  DBUS_TYPE_STRING)                                       \
 162    || (type ==  DBUS_TYPE_OBJECT_PATH)                                  \
 163    || (type ==  DBUS_TYPE_SIGNATURE))
 164
 165 /* This was a macro.  On Solaris 2.11 it was said to compile for
 166    hours, when optimzation is enabled.  So we have transferred it into
 167    a function.  */
 168 /* Determine the DBusType of a given Lisp symbol.  OBJECT must be one
 169    of the predefined D-Bus type symbols.  */
 170 static int
 171 xd_symbol_to_dbus_type (Lisp_Object object)
 172 {
 173   return
 174     ((EQ (object, QCdbus_type_byte)) ? DBUS_TYPE_BYTE
 175      : (EQ (object, QCdbus_type_boolean)) ? DBUS_TYPE_BOOLEAN
 176      : (EQ (object, QCdbus_type_int16)) ? DBUS_TYPE_INT16
 177      : (EQ (object, QCdbus_type_uint16)) ? DBUS_TYPE_UINT16
 178      : (EQ (object, QCdbus_type_int32)) ? DBUS_TYPE_INT32
 179      : (EQ (object, QCdbus_type_uint32)) ? DBUS_TYPE_UINT32
 180      : (EQ (object, QCdbus_type_int64)) ? DBUS_TYPE_INT64
 181      : (EQ (object, QCdbus_type_uint64)) ? DBUS_TYPE_UINT64
 182      : (EQ (object, QCdbus_type_double)) ? DBUS_TYPE_DOUBLE
 183      : (EQ (object, QCdbus_type_string)) ? DBUS_TYPE_STRING
 184      : (EQ (object, QCdbus_type_object_path)) ? DBUS_TYPE_OBJECT_PATH
 185      : (EQ (object, QCdbus_type_signature)) ? DBUS_TYPE_SIGNATURE
 186      : (EQ (object, QCdbus_type_array)) ? DBUS_TYPE_ARRAY
 187      : (EQ (object, QCdbus_type_variant)) ? DBUS_TYPE_VARIANT
 188      : (EQ (object, QCdbus_type_struct)) ? DBUS_TYPE_STRUCT
 189      : (EQ (object, QCdbus_type_dict_entry)) ? DBUS_TYPE_DICT_ENTRY
 190      : DBUS_TYPE_INVALID);
 191 }
 192
 193 /* Check whether a Lisp symbol is a predefined D-Bus type symbol.  */
 194 #define XD_DBUS_TYPE_P(object)                                          \
 195   (SYMBOLP (object) && ((xd_symbol_to_dbus_type (object) != DBUS_TYPE_INVALID)))
 196
 197 /* Determine the DBusType of a given Lisp OBJECT.  It is used to
 198    convert Lisp objects, being arguments of `dbus-call-method' or
 199    `dbus-send-signal', into corresponding C values appended as
 200    arguments to a D-Bus message.  */
 201 #define XD_OBJECT_TO_DBUS_TYPE(object)                                  \
 202   ((EQ (object, Qt) || EQ (object, Qnil)) ? DBUS_TYPE_BOOLEAN           \
 203    : (NATNUMP (object)) ? DBUS_TYPE_UINT32                              \
 204    : (INTEGERP (object)) ? DBUS_TYPE_INT32                              \
 205    : (FLOATP (object)) ? DBUS_TYPE_DOUBLE                               \
 206    : (STRINGP (object)) ? DBUS_TYPE_STRING                              \
 207    : (XD_DBUS_TYPE_P (object)) ? xd_symbol_to_dbus_type (object)        \
 208    : (CONSP (object))                                                   \
 209    ? ((XD_DBUS_TYPE_P (CAR_SAFE (object)))                              \
 210       ? ((XD_BASIC_DBUS_TYPE (xd_symbol_to_dbus_type (CAR_SAFE (object)))) \
 211          ? DBUS_TYPE_ARRAY                                              \
 212          : xd_symbol_to_dbus_type (CAR_SAFE (object)))                  \
 213       : DBUS_TYPE_ARRAY)                                                \
 214    : DBUS_TYPE_INVALID)
 215
 216 /* Return a list pointer which does not have a Lisp symbol as car.  */
 217 #define XD_NEXT_VALUE(object)                                           \
 218   ((XD_DBUS_TYPE_P (CAR_SAFE (object))) ? CDR_SAFE (object) : object)
 219
 220 /* Compute SIGNATURE of OBJECT.  It must have a form that it can be
 221    used in dbus_message_iter_open_container.  DTYPE is the DBusType
 222    the object is related to.  It is passed as argument, because it
 223    cannot be detected in basic type objects, when they are preceded by
 224    a type symbol.  PARENT_TYPE is the DBusType of a container this
 225    signature is embedded, or DBUS_TYPE_INVALID.  It is needed for the
 226    check that DBUS_TYPE_DICT_ENTRY occurs only as array element.  */
 227 static void
 228 xd_signature (char *signature, unsigned int dtype, unsigned int parent_type, Lisp_Object object)
 229 {
 230   unsigned int subtype;
 231   Lisp_Object elt;
 232   char x[DBUS_MAXIMUM_SIGNATURE_LENGTH];
 233
 234   elt = object;
 235
 236   switch (dtype)
 237     {
 238     case DBUS_TYPE_BYTE:
 239     case DBUS_TYPE_UINT16:
 240     case DBUS_TYPE_UINT32:
 241     case DBUS_TYPE_UINT64:
 242       CHECK_NATNUM (object);
 243       sprintf (signature, "%c", dtype);
 244       break;
 245
 246     case DBUS_TYPE_BOOLEAN:
 247       if (!EQ (object, Qt) && !EQ (object, Qnil))
 248         wrong_type_argument (intern ("booleanp"), object);
 249       sprintf (signature, "%c", dtype);
 250       break;
 251
 252     case DBUS_TYPE_INT16:
 253     case DBUS_TYPE_INT32:
 254     case DBUS_TYPE_INT64:
 255       CHECK_NUMBER (object);
 256       sprintf (signature, "%c", dtype);
 257       break;
 258
 259     case DBUS_TYPE_DOUBLE:
 260       CHECK_FLOAT (object);
 261       sprintf (signature, "%c", dtype);
 262       break;
 263
 264     case DBUS_TYPE_STRING:
 265     case DBUS_TYPE_OBJECT_PATH:
 266     case DBUS_TYPE_SIGNATURE:
 267       CHECK_STRING (object);
 268       sprintf (signature, "%c", dtype);
 269       break;
 270
 271     case DBUS_TYPE_ARRAY:
 272       /* Check that all list elements have the same D-Bus type.  For
 273          complex element types, we just check the container type, not
 274          the whole element's signature.  */
 275       CHECK_CONS (object);
 276
 277       /* Type symbol is optional.  */
 278       if (EQ (QCdbus_type_array, CAR_SAFE (elt)))
 279         elt = XD_NEXT_VALUE (elt);
 280
 281       /* If the array is empty, DBUS_TYPE_STRING is the default
 282          element type.  */
 283       if (NILP (elt))
 284         {
 285           subtype = DBUS_TYPE_STRING;
 286           strcpy (x, DBUS_TYPE_STRING_AS_STRING);
 287         }
 288       else
 289         {
 290           subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
 291           xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
 292         }
 293
 294       /* If the element type is DBUS_TYPE_SIGNATURE, and this is the
 295          only element, the value of this element is used as he array's
 296          element signature.  */
 297       if ((subtype == DBUS_TYPE_SIGNATURE)
 298           && STRINGP (CAR_SAFE (XD_NEXT_VALUE (elt)))
 299           && NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
 300         strcpy (x, SDATA (CAR_SAFE (XD_NEXT_VALUE (elt))));
 301
 302       while (!NILP (elt))
 303         {
 304           if (subtype != XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt)))
 305             wrong_type_argument (intern ("D-Bus"), CAR_SAFE (elt));
 306           elt = CDR_SAFE (XD_NEXT_VALUE (elt));
 307         }
 308
 309       sprintf (signature, "%c%s", dtype, x);
 310       break;
 311
 312     case DBUS_TYPE_VARIANT:
 313       /* Check that there is exactly one list element.  */
 314       CHECK_CONS (object);
 315
 316       elt = XD_NEXT_VALUE (elt);
 317       subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
 318       xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
 319
 320       if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
 321         wrong_type_argument (intern ("D-Bus"),
 322                              CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt))));
 323
 324       sprintf (signature, "%c", dtype);
 325       break;
 326
 327     case DBUS_TYPE_STRUCT:
 328       /* A struct list might contain any number of elements with
 329          different types.  No further check needed.  */
 330       CHECK_CONS (object);
 331
 332       elt = XD_NEXT_VALUE (elt);
 333
 334       /* Compose the signature from the elements.  It is enclosed by
 335          parentheses.  */
 336       sprintf (signature, "%c", DBUS_STRUCT_BEGIN_CHAR );
 337       while (!NILP (elt))
 338         {
 339           subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
 340           xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
 341           strcat (signature, x);
 342           elt = CDR_SAFE (XD_NEXT_VALUE (elt));
 343         }
 344       strcat (signature, DBUS_STRUCT_END_CHAR_AS_STRING);
 345       break;
 346
 347     case DBUS_TYPE_DICT_ENTRY:
 348       /* Check that there are exactly two list elements, and the first
 349          one is of basic type.  The dictionary entry itself must be an
 350          element of an array.  */
 351       CHECK_CONS (object);
 352
 353       /* Check the parent object type.  */
 354       if (parent_type != DBUS_TYPE_ARRAY)
 355         wrong_type_argument (intern ("D-Bus"), object);
 356
 357       /* Compose the signature from the elements.  It is enclosed by
 358          curly braces.  */
 359       sprintf (signature, "%c", DBUS_DICT_ENTRY_BEGIN_CHAR);
 360
 361       /* First element.  */
 362       elt = XD_NEXT_VALUE (elt);
 363       subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
 364       xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
 365       strcat (signature, x);
 366
 367       if (!XD_BASIC_DBUS_TYPE (subtype))
 368         wrong_type_argument (intern ("D-Bus"), CAR_SAFE (XD_NEXT_VALUE (elt)));
 369
 370       /* Second element.  */
 371       elt = CDR_SAFE (XD_NEXT_VALUE (elt));
 372       subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
 373       xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
 374       strcat (signature, x);
 375
 376       if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
 377         wrong_type_argument (intern ("D-Bus"),
 378                              CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt))));
 379
 380       /* Closing signature.  */
 381       strcat (signature, DBUS_DICT_ENTRY_END_CHAR_AS_STRING);
 382       break;
 383
 384     default:
 385       wrong_type_argument (intern ("D-Bus"), object);
 386     }
 387
 388   XD_DEBUG_MESSAGE ("%s", signature);
 389 }
 390
 391 /* Append C value, extracted from Lisp OBJECT, to iteration ITER.
 392    DTYPE must be a valid DBusType.  It is used to convert Lisp
 393    objects, being arguments of `dbus-call-method' or
 394    `dbus-send-signal', into corresponding C values appended as
 395    arguments to a D-Bus message.  */
 396 static void
 397 xd_append_arg (unsigned int dtype, Lisp_Object object, DBusMessageIter *iter)
 398 {
 399   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
 400   DBusMessageIter subiter;
 401
 402   if (XD_BASIC_DBUS_TYPE (dtype))
 403     switch (dtype)
 404       {
 405       case DBUS_TYPE_BYTE:
 406         CHECK_NUMBER (object);
 407         {
 408           unsigned char val = XUINT (object) & 0xFF;
 409           XD_DEBUG_MESSAGE ("%c %d", dtype, val);
 410           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 411             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 412           return;
 413         }
 414
 415       case DBUS_TYPE_BOOLEAN:
 416         {
 417           dbus_bool_t val = (NILP (object)) ? FALSE : TRUE;
 418           XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true");
 419           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 420             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 421           return;
 422         }
 423
 424       case DBUS_TYPE_INT16:
 425         CHECK_NUMBER (object);
 426         {
 427           dbus_int16_t val = XINT (object);
 428           XD_DEBUG_MESSAGE ("%c %d", dtype, (int) val);
 429           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 430             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 431           return;
 432         }
 433
 434       case DBUS_TYPE_UINT16:
 435         CHECK_NUMBER (object);
 436         {
 437           dbus_uint16_t val = XUINT (object);
 438           XD_DEBUG_MESSAGE ("%c %u", dtype, (unsigned int) val);
 439           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 440             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 441           return;
 442         }
 443
 444       case DBUS_TYPE_INT32:
 445         CHECK_NUMBER (object);
 446         {
 447           dbus_int32_t val = XINT (object);
 448           XD_DEBUG_MESSAGE ("%c %d", dtype, val);
 449           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 450             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 451           return;
 452         }
 453
 454       case DBUS_TYPE_UINT32:
 455         CHECK_NUMBER (object);
 456         {
 457           dbus_uint32_t val = XUINT (object);
 458           XD_DEBUG_MESSAGE ("%c %u", dtype, val);
 459           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 460             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 461           return;
 462         }
 463
 464       case DBUS_TYPE_INT64:
 465         CHECK_NUMBER (object);
 466         {
 467           dbus_int64_t val = XINT (object);
 468           XD_DEBUG_MESSAGE ("%c %d", dtype, (int) val);
 469           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 470             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 471           return;
 472         }
 473
 474       case DBUS_TYPE_UINT64:
 475         CHECK_NUMBER (object);
 476         {
 477           dbus_uint64_t val = XUINT (object);
 478           XD_DEBUG_MESSAGE ("%c %u", dtype, (unsigned int) val);
 479           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 480             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 481           return;
 482         }
 483
 484       case DBUS_TYPE_DOUBLE:
 485         CHECK_FLOAT (object);
 486         {
 487           double val = XFLOAT_DATA (object);
 488           XD_DEBUG_MESSAGE ("%c %f", dtype, val);
 489           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 490             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 491           return;
 492         }
 493
 494       case DBUS_TYPE_STRING:
 495       case DBUS_TYPE_OBJECT_PATH:
 496       case DBUS_TYPE_SIGNATURE:
 497         CHECK_STRING (object);
 498         {
 499           /* We need to send a valid UTF-8 string.  We could encode `object'
 500              but by not encoding it, we guarantee it's valid utf-8, even if
 501              it contains eight-bit-bytes.  Of course, you can still send
 502              manually-crafted junk by passing a unibyte string.  */
 503           char *val = SDATA (object);
 504           XD_DEBUG_MESSAGE ("%c %s", dtype, val);
 505           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 506             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 507           return;
 508         }
 509       }
 510
 511   else /* Compound types.  */
 512     {
 513
 514       /* All compound types except array have a type symbol.  For
 515          array, it is optional.  Skip it.  */
 516       if (!XD_BASIC_DBUS_TYPE (XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object))))
 517         object = XD_NEXT_VALUE (object);
 518
 519       /* Open new subiteration.  */
 520       switch (dtype)
 521         {
 522         case DBUS_TYPE_ARRAY:
 523           /* An array has only elements of the same type.  So it is
 524              sufficient to check the first element's signature
 525              only.  */
 526
 527           if (NILP (object))
 528             /* If the array is empty, DBUS_TYPE_STRING is the default
 529                element type.  */
 530             strcpy (signature, DBUS_TYPE_STRING_AS_STRING);
 531
 532           else
 533             /* If the element type is DBUS_TYPE_SIGNATURE, and this is
 534                the only element, the value of this element is used as
 535                the array's element signature.  */
 536             if ((XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object))
 537                  == DBUS_TYPE_SIGNATURE)
 538                 && STRINGP (CAR_SAFE (XD_NEXT_VALUE (object)))
 539                 && NILP (CDR_SAFE (XD_NEXT_VALUE (object))))
 540               {
 541                 strcpy (signature, SDATA (CAR_SAFE (XD_NEXT_VALUE (object))));
 542                 object = CDR_SAFE (XD_NEXT_VALUE (object));
 543               }
 544
 545             else
 546               xd_signature (signature,
 547                             XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object)),
 548                             dtype, CAR_SAFE (XD_NEXT_VALUE (object)));
 549
 550           XD_DEBUG_MESSAGE ("%c %s %s", dtype, signature,
 551                             SDATA (format2 ("%s", object, Qnil)));
 552           if (!dbus_message_iter_open_container (iter, dtype,
 553                                                  signature, &subiter))
 554             XD_SIGNAL3 (build_string ("Cannot open container"),
 555                         make_number (dtype), build_string (signature));
 556           break;
 557
 558         case DBUS_TYPE_VARIANT:
 559           /* A variant has just one element.  */
 560           xd_signature (signature, XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object)),
 561                         dtype, CAR_SAFE (XD_NEXT_VALUE (object)));
 562
 563           XD_DEBUG_MESSAGE ("%c %s %s", dtype, signature,
 564                             SDATA (format2 ("%s", object, Qnil)));
 565           if (!dbus_message_iter_open_container (iter, dtype,
 566                                                  signature, &subiter))
 567             XD_SIGNAL3 (build_string ("Cannot open container"),
 568                         make_number (dtype), build_string (signature));
 569           break;
 570
 571         case DBUS_TYPE_STRUCT:
 572         case DBUS_TYPE_DICT_ENTRY:
 573           /* These containers do not require a signature.  */
 574           XD_DEBUG_MESSAGE ("%c %s", dtype,
 575                             SDATA (format2 ("%s", object, Qnil)));
 576           if (!dbus_message_iter_open_container (iter, dtype, NULL, &subiter))
 577             XD_SIGNAL2 (build_string ("Cannot open container"),
 578                         make_number (dtype));
 579           break;
 580         }
 581
 582       /* Loop over list elements.  */
 583       while (!NILP (object))
 584         {
 585           dtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object));
 586           object = XD_NEXT_VALUE (object);
 587
 588           xd_append_arg (dtype, CAR_SAFE (object), &subiter);
 589
 590           object = CDR_SAFE (object);
 591         }
 592
 593       /* Close the subiteration.  */
 594       if (!dbus_message_iter_close_container (iter, &subiter))
 595         XD_SIGNAL2 (build_string ("Cannot close container"),
 596                     make_number (dtype));
 597     }
 598 }
 599
 600 /* Retrieve C value from a DBusMessageIter structure ITER, and return
 601    a converted Lisp object.  The type DTYPE of the argument of the
 602    D-Bus message must be a valid DBusType.  Compound D-Bus types
 603    result always in a Lisp list.  */
 604 static Lisp_Object
 605 xd_retrieve_arg (unsigned int dtype, DBusMessageIter *iter)
 606 {
 607
 608   switch (dtype)
 609     {
 610     case DBUS_TYPE_BYTE:
 611       {
 612         unsigned int val;
 613         dbus_message_iter_get_basic (iter, &val);
 614         val = val & 0xFF;
 615         XD_DEBUG_MESSAGE ("%c %d", dtype, val);
 616         return make_number (val);
 617       }
 618
 619     case DBUS_TYPE_BOOLEAN:
 620       {
 621         dbus_bool_t val;
 622         dbus_message_iter_get_basic (iter, &val);
 623         XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true");
 624         return (val == FALSE) ? Qnil : Qt;
 625       }
 626
 627     case DBUS_TYPE_INT16:
 628       {
 629         dbus_int16_t val;
 630         dbus_message_iter_get_basic (iter, &val);
 631         XD_DEBUG_MESSAGE ("%c %d", dtype, val);
 632         return make_number (val);
 633       }
 634
 635     case DBUS_TYPE_UINT16:
 636       {
 637         dbus_uint16_t val;
 638         dbus_message_iter_get_basic (iter, &val);
 639         XD_DEBUG_MESSAGE ("%c %d", dtype, val);
 640         return make_number (val);
 641       }
 642
 643     case DBUS_TYPE_INT32:
 644       {
 645         dbus_int32_t val;
 646         dbus_message_iter_get_basic (iter, &val);
 647         XD_DEBUG_MESSAGE ("%c %d", dtype, val);
 648         return make_fixnum_or_float (val);
 649       }
 650
 651     case DBUS_TYPE_UINT32:
 652       {
 653         dbus_uint32_t val;
 654         dbus_message_iter_get_basic (iter, &val);
 655         XD_DEBUG_MESSAGE ("%c %d", dtype, val);
 656         return make_fixnum_or_float (val);
 657       }
 658
 659     case DBUS_TYPE_INT64:
 660       {
 661         dbus_int64_t val;
 662         dbus_message_iter_get_basic (iter, &val);
 663         XD_DEBUG_MESSAGE ("%c %d", dtype, (int) val);
 664         return make_fixnum_or_float (val);
 665       }
 666
 667     case DBUS_TYPE_UINT64:
 668       {
 669         dbus_uint64_t val;
 670         dbus_message_iter_get_basic (iter, &val);
 671         XD_DEBUG_MESSAGE ("%c %d", dtype, (int) val);
 672         return make_fixnum_or_float (val);
 673       }
 674
 675     case DBUS_TYPE_DOUBLE:
 676       {
 677         double val;
 678         dbus_message_iter_get_basic (iter, &val);
 679         XD_DEBUG_MESSAGE ("%c %f", dtype, val);
 680         return make_float (val);
 681       }
 682
 683     case DBUS_TYPE_STRING:
 684     case DBUS_TYPE_OBJECT_PATH:
 685     case DBUS_TYPE_SIGNATURE:
 686       {
 687         char *val;
 688         dbus_message_iter_get_basic (iter, &val);
 689         XD_DEBUG_MESSAGE ("%c %s", dtype, val);
 690         return build_string (val);
 691       }
 692
 693     case DBUS_TYPE_ARRAY:
 694     case DBUS_TYPE_VARIANT:
 695     case DBUS_TYPE_STRUCT:
 696     case DBUS_TYPE_DICT_ENTRY:
 697       {
 698         Lisp_Object result;
 699         struct gcpro gcpro1;
 700         DBusMessageIter subiter;
 701         int subtype;
 702         result = Qnil;
 703         GCPRO1 (result);
 704         dbus_message_iter_recurse (iter, &subiter);
 705         while ((subtype = dbus_message_iter_get_arg_type (&subiter))
 706                != DBUS_TYPE_INVALID)
 707           {
 708             result = Fcons (xd_retrieve_arg (subtype, &subiter), result);
 709             dbus_message_iter_next (&subiter);
 710           }
 711         XD_DEBUG_MESSAGE ("%c %s", dtype, SDATA (format2 ("%s", result, Qnil)));
 712         RETURN_UNGCPRO (Fnreverse (result));
 713       }
 714
 715     default:
 716       XD_DEBUG_MESSAGE ("DBusType '%c' not supported", dtype);
 717       return Qnil;
 718     }
 719 }
 720
 721 /* Initialize D-Bus connection.  BUS is either a Lisp symbol, :system
 722    or :session, or a string denoting the bus address.  It tells which
 723    D-Bus to initialize.  If RAISE_ERROR is non-zero, signal an error
 724    when the connection cannot be initialized.  */
 725 static DBusConnection *
 726 xd_initialize (Lisp_Object bus, int raise_error)
 727 {
 728   DBusConnection *connection;
 729   DBusError derror;
 730
 731   /* Parameter check.  */
 732   if (!STRINGP (bus))
 733     {
 734       CHECK_SYMBOL (bus);
 735       if (!(EQ (bus, QCdbus_system_bus) || EQ (bus, QCdbus_session_bus)))
 736         {
 737           if (raise_error)
 738             XD_SIGNAL2 (build_string ("Wrong bus name"), bus);
 739           else
 740             return NULL;
 741         }
 742
 743       /* We do not want to have an autolaunch for the session bus.  */
 744       if (EQ (bus, QCdbus_session_bus)
 745           && getenv ("DBUS_SESSION_BUS_ADDRESS") == NULL)
 746         {
 747           if (raise_error)
 748             XD_SIGNAL2 (build_string ("No connection to bus"), bus);
 749           else
 750             return NULL;
 751         }
 752     }
 753
 754   /* Open a connection to the bus.  */
 755   dbus_error_init (&derror);
 756
 757   if (STRINGP (bus))
 758       connection = dbus_connection_open (SDATA (bus), &derror);
 759   else
 760     if (EQ (bus, QCdbus_system_bus))
 761       connection = dbus_bus_get (DBUS_BUS_SYSTEM, &derror);
 762     else
 763       connection = dbus_bus_get (DBUS_BUS_SESSION, &derror);
 764
 765   if (dbus_error_is_set (&derror))
 766     {
 767       if (raise_error)
 768         XD_ERROR (derror);
 769       else
 770         connection = NULL;
 771     }
 772
 773   /* If it is not the system or session bus, we must register
 774      ourselves.  Otherwise, we have called dbus_bus_get, which has
 775      configured us to exit if the connection closes - we undo this
 776      setting.  */
 777   if (connection != NULL)
 778     {
 779       if (STRINGP (bus))
 780         dbus_bus_register (connection, &derror);
 781       else
 782         dbus_connection_set_exit_on_disconnect (connection, FALSE);
 783     }
 784
 785   if (dbus_error_is_set (&derror))
 786     {
 787       if (raise_error)
 788         XD_ERROR (derror);
 789       else
 790         connection = NULL;
 791     }
 792
 793   if (connection == NULL && raise_error)
 794     XD_SIGNAL2 (build_string ("No connection to bus"), bus);
 795
 796   /* Cleanup.  */
 797   dbus_error_free (&derror);
 798
 799   /* Return the result.  */
 800   return connection;
 801 }
 802
 803 /* Return the file descriptor for WATCH, -1 if not found.  */
 804 static int
 805 xd_find_watch_fd (DBusWatch *watch)
 806 {
 807 #if HAVE_DBUS_WATCH_GET_UNIX_FD
 808   /* TODO: Reverse these on Win32, which prefers the opposite.  */
 809   int fd = dbus_watch_get_unix_fd (watch);
 810   if (fd == -1)
 811     fd = dbus_watch_get_socket (watch);
 812 #else
 813   int fd = dbus_watch_get_fd (watch);
 814 #endif
 815   return fd;
 816 }
 817
 818 /* Prototype.  */
 819 static void
 820 xd_read_queued_messages (int fd, void *data, int for_read);
 821
 822 /* Start monitoring WATCH for possible I/O.  */
 823 static dbus_bool_t
 824 xd_add_watch (DBusWatch *watch, void *data)
 825 {
 826   unsigned int flags = dbus_watch_get_flags (watch);
 827   int fd = xd_find_watch_fd (watch);
 828
 829   XD_DEBUG_MESSAGE ("fd %d, write %d, enabled %d",
 830                     fd, flags & DBUS_WATCH_WRITABLE,
 831                     dbus_watch_get_enabled (watch));
 832
 833   if (fd == -1)
 834     return FALSE;
 835
 836   if (dbus_watch_get_enabled (watch))
 837     {
 838       if (flags & DBUS_WATCH_WRITABLE)
 839         add_write_fd (fd, xd_read_queued_messages, data);
 840       if (flags & DBUS_WATCH_READABLE)
 841         add_read_fd (fd, xd_read_queued_messages, data);
 842     }
 843   return TRUE;
 844 }
 845
 846 /* Stop monitoring WATCH for possible I/O.
 847    DATA is the used bus, either a string or QCdbus_system_bus or
 848    QCdbus_session_bus.  */
 849 static void
 850 xd_remove_watch (DBusWatch *watch, void *data)
 851 {
 852   unsigned int flags = dbus_watch_get_flags (watch);
 853   int fd = xd_find_watch_fd (watch);
 854
 855   XD_DEBUG_MESSAGE ("fd %d", fd);
 856
 857   if (fd == -1)
 858     return;
 859
 860   /* Unset session environment.  */
 861   if (data != NULL && data == (void*) XHASH (QCdbus_session_bus))
 862     {
 863       XD_DEBUG_MESSAGE ("unsetenv DBUS_SESSION_BUS_ADDRESS");
 864       unsetenv ("DBUS_SESSION_BUS_ADDRESS");
 865     }
 866
 867   if (flags & DBUS_WATCH_WRITABLE)
 868     delete_write_fd (fd);
 869   if (flags & DBUS_WATCH_READABLE)
 870     delete_read_fd (fd);
 871 }
 872
 873 /* Toggle monitoring WATCH for possible I/O.  */
 874 static void
 875 xd_toggle_watch (DBusWatch *watch, void *data)
 876 {
 877   if (dbus_watch_get_enabled (watch))
 878     xd_add_watch (watch, data);
 879   else
 880     xd_remove_watch (watch, data);
 881 }
 882
 883 DEFUN ("dbus-init-bus", Fdbus_init_bus, Sdbus_init_bus, 1, 1, 0,
 884        doc: /* Initialize connection to D-Bus BUS.  */)
 885   (Lisp_Object bus)
 886 {
 887   DBusConnection *connection;
 888
 889   /* Open a connection to the bus.  */
 890   connection = xd_initialize (bus, TRUE);
 891
 892   /* Add the watch functions.  We pass also the bus as data, in order
 893      to distinguish between the busses in xd_remove_watch.  */
 894   if (!dbus_connection_set_watch_functions (connection,
 895                                             xd_add_watch,
 896                                             xd_remove_watch,
 897                                             xd_toggle_watch,
 898                                             (void*) XHASH (bus), NULL))
 899     XD_SIGNAL1 (build_string ("Cannot add watch functions"));
 900
 901   /* Add bus to list of registered buses.  */
 902   Vdbus_registered_buses =  Fcons (bus, Vdbus_registered_buses);
 903
 904   /* Return.  */
 905   return Qnil;
 906 }
 907
 908 DEFUN ("dbus-close-bus", Fdbus_close_bus, Sdbus_close_bus, 1, 1, 0,
 909        doc: /* Close connection to D-Bus BUS.  */)
 910   (Lisp_Object bus)
 911 {
 912   DBusConnection *connection;
 913
 914   /* Open a connection to the bus.  */
 915   connection = xd_initialize (bus, TRUE);
 916
 917   /* Decrement reference count to the bus.  */
 918   dbus_connection_unref (connection);
 919
 920   /* Remove bus from list of registered buses.  */
 921   Vdbus_registered_buses = Fdelete (bus, Vdbus_registered_buses);
 922
 923   /* Return.  */
 924   return Qnil;
 925 }
 926
 927 DEFUN ("dbus-get-unique-name", Fdbus_get_unique_name, Sdbus_get_unique_name,
 928        1, 1, 0,
 929        doc: /* Return the unique name of Emacs registered at D-Bus BUS.  */)
 930   (Lisp_Object bus)
 931 {
 932   DBusConnection *connection;
 933   const char *name;
 934
 935   /* Open a connection to the bus.  */
 936   connection = xd_initialize (bus, TRUE);
 937
 938   /* Request the name.  */
 939   name = dbus_bus_get_unique_name (connection);
 940   if (name == NULL)
 941     XD_SIGNAL1 (build_string ("No unique name available"));
 942
 943   /* Return.  */
 944   return build_string (name);
 945 }
 946
 947 DEFUN ("dbus-call-method", Fdbus_call_method, Sdbus_call_method, 5, MANY, 0,
 948        doc: /* Call METHOD on the D-Bus BUS.
 949
 950 BUS is either a Lisp symbol, `:system' or `:session', or a string
 951 denoting the bus address.
 952
 953 SERVICE is the D-Bus service name to be used.  PATH is the D-Bus
 954 object path SERVICE is registered at.  INTERFACE is an interface
 955 offered by SERVICE.  It must provide METHOD.
 956
 957 If the parameter `:timeout' is given, the following integer TIMEOUT
 958 specifies the maximum number of milliseconds the method call must
 959 return.  The default value is 25,000.  If the method call doesn't
 960 return in time, a D-Bus error is raised.
 961
 962 All other arguments ARGS are passed to METHOD as arguments.  They are
 963 converted into D-Bus types via the following rules:
 964
 965   t and nil => DBUS_TYPE_BOOLEAN
 966   number    => DBUS_TYPE_UINT32
 967   integer   => DBUS_TYPE_INT32
 968   float     => DBUS_TYPE_DOUBLE
 969   string    => DBUS_TYPE_STRING
 970   list      => DBUS_TYPE_ARRAY
 971
 972 All arguments can be preceded by a type symbol.  For details about
 973 type symbols, see Info node `(dbus)Type Conversion'.
 974
 975 `dbus-call-method' returns the resulting values of METHOD as a list of
 976 Lisp objects.  The type conversion happens the other direction as for
 977 input arguments.  It follows the mapping rules:
 978
 979   DBUS_TYPE_BOOLEAN     => t or nil
 980   DBUS_TYPE_BYTE        => number
 981   DBUS_TYPE_UINT16      => number
 982   DBUS_TYPE_INT16       => integer
 983   DBUS_TYPE_UINT32      => number or float
 984   DBUS_TYPE_INT32       => integer or float
 985   DBUS_TYPE_UINT64      => number or float
 986   DBUS_TYPE_INT64       => integer or float
 987   DBUS_TYPE_DOUBLE      => float
 988   DBUS_TYPE_STRING      => string
 989   DBUS_TYPE_OBJECT_PATH => string
 990   DBUS_TYPE_SIGNATURE   => string
 991   DBUS_TYPE_ARRAY       => list
 992   DBUS_TYPE_VARIANT     => list
 993   DBUS_TYPE_STRUCT      => list
 994   DBUS_TYPE_DICT_ENTRY  => list
 995
 996 Example:
 997
 998 \(dbus-call-method
 999   :session "org.gnome.seahorse" "/org/gnome/seahorse/keys/openpgp"
1000   "org.gnome.seahorse.Keys" "GetKeyField"
1001   "openpgp:657984B8C7A966DD" "simple-name")
1002
1003   => (t ("Philip R. Zimmermann"))
1004
1005 If the result of the METHOD call is just one value, the converted Lisp
1006 object is returned instead of a list containing this single Lisp object.
1007
1008 \(dbus-call-method
1009   :system "org.freedesktop.Hal" "/org/freedesktop/Hal/devices/computer"
1010   "org.freedesktop.Hal.Device" "GetPropertyString"
1011   "system.kernel.machine")
1012
1013   => "i686"
1014
1015 usage: (dbus-call-method BUS SERVICE PATH INTERFACE METHOD &optional :timeout TIMEOUT &rest ARGS)  */)
1016   (int nargs, register Lisp_Object *args)
1017 {
1018   Lisp_Object bus, service, path, interface, method;
1019   Lisp_Object result;
1020   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
1021   DBusConnection *connection;
1022   DBusMessage *dmessage;
1023   DBusMessage *reply;
1024   DBusMessageIter iter;
1025   DBusError derror;
1026   unsigned int dtype;
1027   int timeout = -1;
1028   int i = 5;
1029   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1030
1031   /* Check parameters.  */
1032   bus = args[0];
1033   service = args[1];
1034   path = args[2];
1035   interface = args[3];
1036   method = args[4];
1037
1038   CHECK_STRING (service);
1039   CHECK_STRING (path);
1040   CHECK_STRING (interface);
1041   CHECK_STRING (method);
1042   GCPRO5 (bus, service, path, interface, method);
1043
1044   XD_DEBUG_MESSAGE ("%s %s %s %s",
1045                     SDATA (service),
1046                     SDATA (path),
1047                     SDATA (interface),
1048                     SDATA (method));
1049
1050   /* Open a connection to the bus.  */
1051   connection = xd_initialize (bus, TRUE);
1052
1053   /* Create the message.  */
1054   dmessage = dbus_message_new_method_call (SDATA (service),
1055                                            SDATA (path),
1056                                            SDATA (interface),
1057                                            SDATA (method));
1058   UNGCPRO;
1059   if (dmessage == NULL)
1060     XD_SIGNAL1 (build_string ("Unable to create a new message"));
1061
1062   /* Check for timeout parameter.  */
1063   if ((i+2 <= nargs) && (EQ ((args[i]), QCdbus_timeout)))
1064     {
1065       CHECK_NATNUM (args[i+1]);
1066       timeout = XUINT (args[i+1]);
1067       i = i+2;
1068     }
1069
1070   /* Initialize parameter list of message.  */
1071   dbus_message_iter_init_append (dmessage, &iter);
1072
1073   /* Append parameters to the message.  */
1074   for (; i < nargs; ++i)
1075     {
1076       dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1077       if (XD_DBUS_TYPE_P (args[i]))
1078         {
1079           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1080           XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1081           XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-4,
1082                             SDATA (format2 ("%s", args[i], Qnil)),
1083                             SDATA (format2 ("%s", args[i+1], Qnil)));
1084           ++i;
1085         }
1086       else
1087         {
1088           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1089           XD_DEBUG_MESSAGE ("Parameter%d %s", i-4,
1090                             SDATA (format2 ("%s", args[i], Qnil)));
1091         }
1092
1093       /* Check for valid signature.  We use DBUS_TYPE_INVALID as
1094          indication that there is no parent type.  */
1095       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1096
1097       xd_append_arg (dtype, args[i], &iter);
1098     }
1099
1100   /* Send the message.  */
1101   dbus_error_init (&derror);
1102   reply = dbus_connection_send_with_reply_and_block (connection,
1103                                                      dmessage,
1104                                                      timeout,
1105                                                      &derror);
1106
1107   if (dbus_error_is_set (&derror))
1108     XD_ERROR (derror);
1109
1110   if (reply == NULL)
1111     XD_SIGNAL1 (build_string ("No reply"));
1112
1113   XD_DEBUG_MESSAGE ("Message sent");
1114
1115   /* Collect the results.  */
1116   result = Qnil;
1117   GCPRO1 (result);
1118
1119   if (dbus_message_iter_init (reply, &iter))
1120     {
1121       /* Loop over the parameters of the D-Bus reply message.  Construct a
1122          Lisp list, which is returned by `dbus-call-method'.  */
1123       while ((dtype = dbus_message_iter_get_arg_type (&iter))
1124              != DBUS_TYPE_INVALID)
1125         {
1126           result = Fcons (xd_retrieve_arg (dtype, &iter), result);
1127           dbus_message_iter_next (&iter);
1128         }
1129     }
1130   else
1131     {
1132       /* No arguments: just return nil.  */
1133     }
1134
1135   /* Cleanup.  */
1136   dbus_error_free (&derror);
1137   dbus_message_unref (dmessage);
1138   dbus_message_unref (reply);
1139
1140   /* Return the result.  If there is only one single Lisp object,
1141      return it as-it-is, otherwise return the reversed list.  */
1142   if (XUINT (Flength (result)) == 1)
1143     RETURN_UNGCPRO (CAR_SAFE (result));
1144   else
1145     RETURN_UNGCPRO (Fnreverse (result));
1146 }
1147
1148 DEFUN ("dbus-call-method-asynchronously", Fdbus_call_method_asynchronously,
1149        Sdbus_call_method_asynchronously, 6, MANY, 0,
1150        doc: /* Call METHOD on the D-Bus BUS asynchronously.
1151
1152 BUS is either a Lisp symbol, `:system' or `:session', or a string
1153 denoting the bus address.
1154
1155 SERVICE is the D-Bus service name to be used.  PATH is the D-Bus
1156 object path SERVICE is registered at.  INTERFACE is an interface
1157 offered by SERVICE.  It must provide METHOD.
1158
1159 HANDLER is a Lisp function, which is called when the corresponding
1160 return message has arrived.  If HANDLER is nil, no return message will
1161 be expected.
1162
1163 If the parameter `:timeout' is given, the following integer TIMEOUT
1164 specifies the maximum number of milliseconds the method call must
1165 return.  The default value is 25,000.  If the method call doesn't
1166 return in time, a D-Bus error is raised.
1167
1168 All other arguments ARGS are passed to METHOD as arguments.  They are
1169 converted into D-Bus types via the following rules:
1170
1171   t and nil => DBUS_TYPE_BOOLEAN
1172   number    => DBUS_TYPE_UINT32
1173   integer   => DBUS_TYPE_INT32
1174   float     => DBUS_TYPE_DOUBLE
1175   string    => DBUS_TYPE_STRING
1176   list      => DBUS_TYPE_ARRAY
1177
1178 All arguments can be preceded by a type symbol.  For details about
1179 type symbols, see Info node `(dbus)Type Conversion'.
1180
1181 Unless HANDLER is nil, the function returns a key into the hash table
1182 `dbus-registered-objects-table'.  The corresponding entry in the hash
1183 table is removed, when the return message has been arrived, and
1184 HANDLER is called.
1185
1186 Example:
1187
1188 \(dbus-call-method-asynchronously
1189   :system "org.freedesktop.Hal" "/org/freedesktop/Hal/devices/computer"
1190   "org.freedesktop.Hal.Device" "GetPropertyString" 'message
1191   "system.kernel.machine")
1192
1193   => (:system 2)
1194
1195   -| i686
1196
1197 usage: (dbus-call-method-asynchronously BUS SERVICE PATH INTERFACE METHOD HANDLER &optional :timeout TIMEOUT &rest ARGS)  */)
1198   (int nargs, register Lisp_Object *args)
1199 {
1200   Lisp_Object bus, service, path, interface, method, handler;
1201   Lisp_Object result;
1202   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5, gcpro6;
1203   DBusConnection *connection;
1204   DBusMessage *dmessage;
1205   DBusMessageIter iter;
1206   unsigned int dtype;
1207   int timeout = -1;
1208   int i = 6;
1209   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1210
1211   /* Check parameters.  */
1212   bus = args[0];
1213   service = args[1];
1214   path = args[2];
1215   interface = args[3];
1216   method = args[4];
1217   handler = args[5];
1218
1219   CHECK_STRING (service);
1220   CHECK_STRING (path);
1221   CHECK_STRING (interface);
1222   CHECK_STRING (method);
1223   if (!NILP (handler) && !FUNCTIONP (handler))
1224     wrong_type_argument (intern ("functionp"), handler);
1225   GCPRO6 (bus, service, path, interface, method, handler);
1226
1227   XD_DEBUG_MESSAGE ("%s %s %s %s",
1228                     SDATA (service),
1229                     SDATA (path),
1230                     SDATA (interface),
1231                     SDATA (method));
1232
1233   /* Open a connection to the bus.  */
1234   connection = xd_initialize (bus, TRUE);
1235
1236   /* Create the message.  */
1237   dmessage = dbus_message_new_method_call (SDATA (service),
1238                                            SDATA (path),
1239                                            SDATA (interface),
1240                                            SDATA (method));
1241   if (dmessage == NULL)
1242     XD_SIGNAL1 (build_string ("Unable to create a new message"));
1243
1244   /* Check for timeout parameter.  */
1245   if ((i+2 <= nargs) && (EQ ((args[i]), QCdbus_timeout)))
1246     {
1247       CHECK_NATNUM (args[i+1]);
1248       timeout = XUINT (args[i+1]);
1249       i = i+2;
1250     }
1251
1252   /* Initialize parameter list of message.  */
1253   dbus_message_iter_init_append (dmessage, &iter);
1254
1255   /* Append parameters to the message.  */
1256   for (; i < nargs; ++i)
1257     {
1258       dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1259       if (XD_DBUS_TYPE_P (args[i]))
1260         {
1261           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1262           XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1263           XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-4,
1264                             SDATA (format2 ("%s", args[i], Qnil)),
1265                             SDATA (format2 ("%s", args[i+1], Qnil)));
1266           ++i;
1267         }
1268       else
1269         {
1270           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1271           XD_DEBUG_MESSAGE ("Parameter%d %s", i-4,
1272                             SDATA (format2 ("%s", args[i], Qnil)));
1273         }
1274
1275       /* Check for valid signature.  We use DBUS_TYPE_INVALID as
1276          indication that there is no parent type.  */
1277       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1278
1279       xd_append_arg (dtype, args[i], &iter);
1280     }
1281
1282   if (!NILP (handler))
1283     {
1284       /* Send the message.  The message is just added to the outgoing
1285          message queue.  */
1286       if (!dbus_connection_send_with_reply (connection, dmessage,
1287                                             NULL, timeout))
1288         XD_SIGNAL1 (build_string ("Cannot send message"));
1289
1290       /* The result is the key in Vdbus_registered_objects_table.  */
1291       result = (list2 (bus, make_number (dbus_message_get_serial (dmessage))));
1292
1293       /* Create a hash table entry.  */
1294       Fputhash (result, handler, Vdbus_registered_objects_table);
1295     }
1296   else
1297     {
1298       /* Send the message.  The message is just added to the outgoing
1299          message queue.  */
1300       if (!dbus_connection_send (connection, dmessage, NULL))
1301         XD_SIGNAL1 (build_string ("Cannot send message"));
1302
1303       result = Qnil;
1304     }
1305
1306   XD_DEBUG_MESSAGE ("Message sent");
1307
1308   /* Cleanup.  */
1309   dbus_message_unref (dmessage);
1310
1311   /* Return the result.  */
1312   RETURN_UNGCPRO (result);
1313 }
1314
1315 DEFUN ("dbus-method-return-internal", Fdbus_method_return_internal,
1316        Sdbus_method_return_internal,
1317        3, MANY, 0,
1318        doc: /* Return for message SERIAL on the D-Bus BUS.
1319 This is an internal function, it shall not be used outside dbus.el.
1320
1321 usage: (dbus-method-return-internal BUS SERIAL SERVICE &rest ARGS)  */)
1322   (int nargs, register Lisp_Object *args)
1323 {
1324   Lisp_Object bus, serial, service;
1325   struct gcpro gcpro1, gcpro2, gcpro3;
1326   DBusConnection *connection;
1327   DBusMessage *dmessage;
1328   DBusMessageIter iter;
1329   unsigned int dtype;
1330   int i;
1331   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1332
1333   /* Check parameters.  */
1334   bus = args[0];
1335   serial = args[1];
1336   service = args[2];
1337
1338   CHECK_NUMBER (serial);
1339   CHECK_STRING (service);
1340   GCPRO3 (bus, serial, service);
1341
1342   XD_DEBUG_MESSAGE ("%lu %s ", (unsigned long) XUINT (serial), SDATA (service));
1343
1344   /* Open a connection to the bus.  */
1345   connection = xd_initialize (bus, TRUE);
1346
1347   /* Create the message.  */
1348   dmessage = dbus_message_new (DBUS_MESSAGE_TYPE_METHOD_RETURN);
1349   if ((dmessage == NULL)
1350       || (!dbus_message_set_reply_serial (dmessage, XUINT (serial)))
1351       || (!dbus_message_set_destination (dmessage, SDATA (service))))
1352     {
1353       UNGCPRO;
1354       XD_SIGNAL1 (build_string ("Unable to create a return message"));
1355     }
1356
1357   UNGCPRO;
1358
1359   /* Initialize parameter list of message.  */
1360   dbus_message_iter_init_append (dmessage, &iter);
1361
1362   /* Append parameters to the message.  */
1363   for (i = 3; i < nargs; ++i)
1364     {
1365       dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1366       if (XD_DBUS_TYPE_P (args[i]))
1367         {
1368           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1369           XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1370           XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-2,
1371                             SDATA (format2 ("%s", args[i], Qnil)),
1372                             SDATA (format2 ("%s", args[i+1], Qnil)));
1373           ++i;
1374         }
1375       else
1376         {
1377           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1378           XD_DEBUG_MESSAGE ("Parameter%d %s", i-2,
1379                             SDATA (format2 ("%s", args[i], Qnil)));
1380         }
1381
1382       /* Check for valid signature.  We use DBUS_TYPE_INVALID as
1383          indication that there is no parent type.  */
1384       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1385
1386       xd_append_arg (dtype, args[i], &iter);
1387     }
1388
1389   /* Send the message.  The message is just added to the outgoing
1390      message queue.  */
1391   if (!dbus_connection_send (connection, dmessage, NULL))
1392     XD_SIGNAL1 (build_string ("Cannot send message"));
1393
1394   XD_DEBUG_MESSAGE ("Message sent");
1395
1396   /* Cleanup.  */
1397   dbus_message_unref (dmessage);
1398
1399   /* Return.  */
1400   return Qt;
1401 }
1402
1403 DEFUN ("dbus-method-error-internal", Fdbus_method_error_internal,
1404        Sdbus_method_error_internal,
1405        3, MANY, 0,
1406        doc: /* Return error message for message SERIAL on the D-Bus BUS.
1407 This is an internal function, it shall not be used outside dbus.el.
1408
1409 usage: (dbus-method-error-internal BUS SERIAL SERVICE &rest ARGS)  */)
1410   (int nargs, register Lisp_Object *args)
1411 {
1412   Lisp_Object bus, serial, service;
1413   struct gcpro gcpro1, gcpro2, gcpro3;
1414   DBusConnection *connection;
1415   DBusMessage *dmessage;
1416   DBusMessageIter iter;
1417   unsigned int dtype;
1418   int i;
1419   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1420
1421   /* Check parameters.  */
1422   bus = args[0];
1423   serial = args[1];
1424   service = args[2];
1425
1426   CHECK_NUMBER (serial);
1427   CHECK_STRING (service);
1428   GCPRO3 (bus, serial, service);
1429
1430   XD_DEBUG_MESSAGE ("%lu %s ", (unsigned long) XUINT (serial), SDATA (service));
1431
1432   /* Open a connection to the bus.  */
1433   connection = xd_initialize (bus, TRUE);
1434
1435   /* Create the message.  */
1436   dmessage = dbus_message_new (DBUS_MESSAGE_TYPE_ERROR);
1437   if ((dmessage == NULL)
1438       || (!dbus_message_set_error_name (dmessage, DBUS_ERROR_FAILED))
1439       || (!dbus_message_set_reply_serial (dmessage, XUINT (serial)))
1440       || (!dbus_message_set_destination (dmessage, SDATA (service))))
1441     {
1442       UNGCPRO;
1443       XD_SIGNAL1 (build_string ("Unable to create a error message"));
1444     }
1445
1446   UNGCPRO;
1447
1448   /* Initialize parameter list of message.  */
1449   dbus_message_iter_init_append (dmessage, &iter);
1450
1451   /* Append parameters to the message.  */
1452   for (i = 3; i < nargs; ++i)
1453     {
1454       dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1455       if (XD_DBUS_TYPE_P (args[i]))
1456         {
1457           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1458           XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1459           XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-2,
1460                             SDATA (format2 ("%s", args[i], Qnil)),
1461                             SDATA (format2 ("%s", args[i+1], Qnil)));
1462           ++i;
1463         }
1464       else
1465         {
1466           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1467           XD_DEBUG_MESSAGE ("Parameter%d %s", i-2,
1468                             SDATA (format2 ("%s", args[i], Qnil)));
1469         }
1470
1471       /* Check for valid signature.  We use DBUS_TYPE_INVALID as
1472          indication that there is no parent type.  */
1473       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1474
1475       xd_append_arg (dtype, args[i], &iter);
1476     }
1477
1478   /* Send the message.  The message is just added to the outgoing
1479      message queue.  */
1480   if (!dbus_connection_send (connection, dmessage, NULL))
1481     XD_SIGNAL1 (build_string ("Cannot send message"));
1482
1483   XD_DEBUG_MESSAGE ("Message sent");
1484
1485   /* Cleanup.  */
1486   dbus_message_unref (dmessage);
1487
1488   /* Return.  */
1489   return Qt;
1490 }
1491
1492 DEFUN ("dbus-send-signal", Fdbus_send_signal, Sdbus_send_signal, 5, MANY, 0,
1493        doc: /* Send signal SIGNAL on the D-Bus BUS.
1494
1495 BUS is either a Lisp symbol, `:system' or `:session', or a string
1496 denoting the bus address.
1497
1498 SERVICE is the D-Bus service name SIGNAL is sent from.  PATH is the
1499 D-Bus object path SERVICE is registered at.  INTERFACE is an interface
1500 offered by SERVICE.  It must provide signal SIGNAL.
1501
1502 All other arguments ARGS are passed to SIGNAL as arguments.  They are
1503 converted into D-Bus types via the following rules:
1504
1505   t and nil => DBUS_TYPE_BOOLEAN
1506   number    => DBUS_TYPE_UINT32
1507   integer   => DBUS_TYPE_INT32
1508   float     => DBUS_TYPE_DOUBLE
1509   string    => DBUS_TYPE_STRING
1510   list      => DBUS_TYPE_ARRAY
1511
1512 All arguments can be preceded by a type symbol.  For details about
1513 type symbols, see Info node `(dbus)Type Conversion'.
1514
1515 Example:
1516
1517 \(dbus-send-signal
1518   :session "org.gnu.Emacs" "/org/gnu/Emacs"
1519   "org.gnu.Emacs.FileManager" "FileModified" "/home/albinus/.emacs")
1520
1521 usage: (dbus-send-signal BUS SERVICE PATH INTERFACE SIGNAL &rest ARGS)  */)
1522   (int nargs, register Lisp_Object *args)
1523 {
1524   Lisp_Object bus, service, path, interface, signal;
1525   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
1526   DBusConnection *connection;
1527   DBusMessage *dmessage;
1528   DBusMessageIter iter;
1529   unsigned int dtype;
1530   int i;
1531   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1532
1533   /* Check parameters.  */
1534   bus = args[0];
1535   service = args[1];
1536   path = args[2];
1537   interface = args[3];
1538   signal = args[4];
1539
1540   CHECK_STRING (service);
1541   CHECK_STRING (path);
1542   CHECK_STRING (interface);
1543   CHECK_STRING (signal);
1544   GCPRO5 (bus, service, path, interface, signal);
1545
1546   XD_DEBUG_MESSAGE ("%s %s %s %s",
1547                     SDATA (service),
1548                     SDATA (path),
1549                     SDATA (interface),
1550                     SDATA (signal));
1551
1552   /* Open a connection to the bus.  */
1553   connection = xd_initialize (bus, TRUE);
1554
1555   /* Create the message.  */
1556   dmessage = dbus_message_new_signal (SDATA (path),
1557                                       SDATA (interface),
1558                                       SDATA (signal));
1559   UNGCPRO;
1560   if (dmessage == NULL)
1561     XD_SIGNAL1 (build_string ("Unable to create a new message"));
1562
1563   /* Initialize parameter list of message.  */
1564   dbus_message_iter_init_append (dmessage, &iter);
1565
1566   /* Append parameters to the message.  */
1567   for (i = 5; i < nargs; ++i)
1568     {
1569       dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1570       if (XD_DBUS_TYPE_P (args[i]))
1571         {
1572           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1573           XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1574           XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-4,
1575                             SDATA (format2 ("%s", args[i], Qnil)),
1576                             SDATA (format2 ("%s", args[i+1], Qnil)));
1577           ++i;
1578         }
1579       else
1580         {
1581           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1582           XD_DEBUG_MESSAGE ("Parameter%d %s", i-4,
1583                             SDATA (format2 ("%s", args[i], Qnil)));
1584         }
1585
1586       /* Check for valid signature.  We use DBUS_TYPE_INVALID as
1587          indication that there is no parent type.  */
1588       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1589
1590       xd_append_arg (dtype, args[i], &iter);
1591     }
1592
1593   /* Send the message.  The message is just added to the outgoing
1594      message queue.  */
1595   if (!dbus_connection_send (connection, dmessage, NULL))
1596     XD_SIGNAL1 (build_string ("Cannot send message"));
1597
1598   XD_DEBUG_MESSAGE ("Signal sent");
1599
1600   /* Cleanup.  */
1601   dbus_message_unref (dmessage);
1602
1603   /* Return.  */
1604   return Qt;
1605 }
1606
1607 /* Read one queued incoming message of the D-Bus BUS.
1608    BUS is either a Lisp symbol, :system or :session, or a string denoting
1609    the bus address.  */
1610 static void
1611 xd_read_message_1 (DBusConnection *connection, Lisp_Object bus)
1612 {
1613   Lisp_Object args, key, value;
1614   struct gcpro gcpro1;
1615   struct input_event event;
1616   DBusMessage *dmessage;
1617   DBusMessageIter iter;
1618   unsigned int dtype;
1619   int mtype, serial;
1620   const char *uname, *path, *interface, *member;
1621
1622   dmessage = dbus_connection_pop_message (connection);
1623
1624   /* Return if there is no queued message.  */
1625   if (dmessage == NULL)
1626     return;
1627
1628   /* Collect the parameters.  */
1629   args = Qnil;
1630   GCPRO1 (args);
1631
1632   /* Loop over the resulting parameters.  Construct a list.  */
1633   if (dbus_message_iter_init (dmessage, &iter))
1634     {
1635       while ((dtype = dbus_message_iter_get_arg_type (&iter))
1636              != DBUS_TYPE_INVALID)
1637         {
1638           args = Fcons (xd_retrieve_arg (dtype, &iter), args);
1639           dbus_message_iter_next (&iter);
1640         }
1641       /* The arguments are stored in reverse order.  Reorder them.  */
1642       args = Fnreverse (args);
1643     }
1644
1645   /* Read message type, message serial, unique name, object path,
1646      interface and member from the message.  */
1647   mtype = dbus_message_get_type (dmessage);
1648   serial =
1649     ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1650      || (mtype == DBUS_MESSAGE_TYPE_ERROR))
1651     ? dbus_message_get_reply_serial (dmessage)
1652     : dbus_message_get_serial (dmessage);
1653   uname = dbus_message_get_sender (dmessage);
1654   path = dbus_message_get_path (dmessage);
1655   interface = dbus_message_get_interface (dmessage);
1656   member = dbus_message_get_member (dmessage);
1657
1658   XD_DEBUG_MESSAGE ("Event received: %s %d %s %s %s %s %s",
1659                     (mtype == DBUS_MESSAGE_TYPE_INVALID)
1660                     ? "DBUS_MESSAGE_TYPE_INVALID"
1661                     : (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1662                     ? "DBUS_MESSAGE_TYPE_METHOD_CALL"
1663                     : (mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1664                     ? "DBUS_MESSAGE_TYPE_METHOD_RETURN"
1665                     : (mtype == DBUS_MESSAGE_TYPE_ERROR)
1666                     ? "DBUS_MESSAGE_TYPE_ERROR"
1667                     : "DBUS_MESSAGE_TYPE_SIGNAL",
1668                     serial, uname, path, interface, member,
1669                     SDATA (format2 ("%s", args, Qnil)));
1670
1671   if ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1672       || (mtype == DBUS_MESSAGE_TYPE_ERROR))
1673     {
1674       /* Search for a registered function of the message.  */
1675       key = list2 (bus, make_number (serial));
1676       value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1677
1678       /* There shall be exactly one entry.  Construct an event.  */
1679       if (NILP (value))
1680         goto cleanup;
1681
1682       /* Remove the entry.  */
1683       Fremhash (key, Vdbus_registered_objects_table);
1684
1685       /* Construct an event.  */
1686       EVENT_INIT (event);
1687       event.kind = DBUS_EVENT;
1688       event.frame_or_window = Qnil;
1689       event.arg = Fcons (value, args);
1690     }
1691
1692   else /* (mtype != DBUS_MESSAGE_TYPE_METHOD_RETURN)  */
1693     {
1694       /* Vdbus_registered_objects_table requires non-nil interface and
1695          member.  */
1696       if ((interface == NULL) || (member == NULL))
1697         goto cleanup;
1698
1699       /* Search for a registered function of the message.  */
1700       key = list3 (bus, build_string (interface), build_string (member));
1701       value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1702
1703       /* Loop over the registered functions.  Construct an event.  */
1704       while (!NILP (value))
1705         {
1706           key = CAR_SAFE (value);
1707           /* key has the structure (UNAME SERVICE PATH HANDLER).  */
1708           if (((uname == NULL)
1709                || (NILP (CAR_SAFE (key)))
1710                || (strcmp (uname, SDATA (CAR_SAFE (key))) == 0))
1711               && ((path == NULL)
1712                   || (NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1713                   || (strcmp (path,
1714                               SDATA (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1715                       == 0))
1716               && (!NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))))))
1717             {
1718               EVENT_INIT (event);
1719               event.kind = DBUS_EVENT;
1720               event.frame_or_window = Qnil;
1721               event.arg = Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))),
1722                                  args);
1723               break;
1724             }
1725           value = CDR_SAFE (value);
1726         }
1727
1728       if (NILP (value))
1729         goto cleanup;
1730     }
1731
1732   /* Add type, serial, uname, path, interface and member to the event.  */
1733   event.arg = Fcons ((member == NULL ? Qnil : build_string (member)),
1734                      event.arg);
1735   event.arg = Fcons ((interface == NULL ? Qnil : build_string (interface)),
1736                      event.arg);
1737   event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
1738                      event.arg);
1739   event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
1740                      event.arg);
1741   event.arg = Fcons (make_number (serial), event.arg);
1742   event.arg = Fcons (make_number (mtype), event.arg);
1743
1744   /* Add the bus symbol to the event.  */
1745   event.arg = Fcons (bus, event.arg);
1746
1747   /* Store it into the input event queue.  */
1748   kbd_buffer_store_event (&event);
1749
1750   XD_DEBUG_MESSAGE ("Event stored: %s",
1751                     SDATA (format2 ("%s", event.arg, Qnil)));
1752
1753   /* Cleanup.  */
1754  cleanup:
1755   dbus_message_unref (dmessage);
1756
1757   UNGCPRO;
1758 }
1759
1760 /* Read queued incoming messages of the D-Bus BUS.
1761    BUS is either a Lisp symbol, :system or :session, or a string denoting
1762    the bus address.  */
1763 static Lisp_Object
1764 xd_read_message (Lisp_Object bus)
1765 {
1766   /* Open a connection to the bus.  */
1767   DBusConnection *connection = xd_initialize (bus, TRUE);
1768
1769   /* Non blocking read of the next available message.  */
1770   dbus_connection_read_write (connection, 0);
1771
1772   while (dbus_connection_get_dispatch_status (connection)
1773          != DBUS_DISPATCH_COMPLETE)
1774     xd_read_message_1 (connection, bus);
1775   return Qnil;
1776 }
1777
1778 /* Callback called when something is ready to read or write.  */
1779 static void
1780 xd_read_queued_messages (int fd, void *data, int for_read)
1781 {
1782   Lisp_Object busp = Vdbus_registered_buses;
1783   Lisp_Object bus = Qnil;
1784
1785   /* Find bus related to fd.  */
1786   if (data != NULL)
1787     while (!NILP (busp))
1788       {
1789         if (data == (void*) XHASH (CAR_SAFE (busp)))
1790           bus = CAR_SAFE (busp);
1791         busp = CDR_SAFE (busp);
1792       }
1793
1794   if (NILP(bus))
1795     return;
1796
1797   /* We ignore all Lisp errors during the call.  */
1798   xd_in_read_queued_messages = 1;
1799   internal_catch (Qdbus_error, xd_read_message, bus);
1800   xd_in_read_queued_messages = 0;
1801 }
1802
1803 DEFUN ("dbus-register-signal", Fdbus_register_signal, Sdbus_register_signal,
1804        6, MANY, 0,
1805        doc: /* Register for signal SIGNAL on the D-Bus BUS.
1806
1807 BUS is either a Lisp symbol, `:system' or `:session', or a string
1808 denoting the bus address.
1809
1810 SERVICE is the D-Bus service name used by the sending D-Bus object.
1811 It can be either a known name or the unique name of the D-Bus object
1812 sending the signal.  When SERVICE is nil, related signals from all
1813 D-Bus objects shall be accepted.
1814
1815 PATH is the D-Bus object path SERVICE is registered.  It can also be
1816 nil if the path name of incoming signals shall not be checked.
1817
1818 INTERFACE is an interface offered by SERVICE.  It must provide SIGNAL.
1819 HANDLER is a Lisp function to be called when the signal is received.
1820 It must accept as arguments the values SIGNAL is sending.
1821
1822 All other arguments ARGS, if specified, must be strings.  They stand
1823 for the respective arguments of the signal in their order, and are
1824 used for filtering as well.  A nil argument might be used to preserve
1825 the order.
1826
1827 INTERFACE, SIGNAL and HANDLER must not be nil.  Example:
1828
1829 \(defun my-signal-handler (device)
1830   (message "Device %s added" device))
1831
1832 \(dbus-register-signal
1833   :system "org.freedesktop.Hal" "/org/freedesktop/Hal/Manager"
1834   "org.freedesktop.Hal.Manager" "DeviceAdded" 'my-signal-handler)
1835
1836   => ((:system "org.freedesktop.Hal.Manager" "DeviceAdded")
1837       ("org.freedesktop.Hal" "/org/freedesktop/Hal/Manager" my-signal-handler))
1838
1839 `dbus-register-signal' returns an object, which can be used in
1840 `dbus-unregister-object' for removing the registration.
1841
1842 usage: (dbus-register-signal BUS SERVICE PATH INTERFACE SIGNAL HANDLER &rest ARGS) */)
1843   (int nargs, register Lisp_Object *args)
1844 {
1845   Lisp_Object bus, service, path, interface, signal, handler;
1846   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5, gcpro6;
1847   Lisp_Object uname, key, key1, value;
1848   DBusConnection *connection;
1849   int i;
1850   char rule[DBUS_MAXIMUM_MATCH_RULE_LENGTH];
1851   char x[DBUS_MAXIMUM_MATCH_RULE_LENGTH];
1852   DBusError derror;
1853
1854   /* Check parameters.  */
1855   bus = args[0];
1856   service = args[1];
1857   path = args[2];
1858   interface = args[3];
1859   signal = args[4];
1860   handler = args[5];
1861
1862   if (!NILP (service)) CHECK_STRING (service);
1863   if (!NILP (path)) CHECK_STRING (path);
1864   CHECK_STRING (interface);
1865   CHECK_STRING (signal);
1866   if (!FUNCTIONP (handler))
1867     wrong_type_argument (intern ("functionp"), handler);
1868   GCPRO6 (bus, service, path, interface, signal, handler);
1869
1870   /* Retrieve unique name of service.  If service is a known name, we
1871      will register for the corresponding unique name, if any.  Signals
1872      are sent always with the unique name as sender.  Note: the unique
1873      name of "org.freedesktop.DBus" is that string itself.  */
1874   if ((STRINGP (service))
1875       && (SBYTES (service) > 0)
1876       && (strcmp (SDATA (service), DBUS_SERVICE_DBUS) != 0)
1877       && (strncmp (SDATA (service), ":", 1) != 0))
1878     {
1879       uname = call2 (intern ("dbus-get-name-owner"), bus, service);
1880       /* When there is no unique name, we mark it with an empty
1881          string.  */
1882       if (NILP (uname))
1883         uname = empty_unibyte_string;
1884     }
1885   else
1886     uname = service;
1887
1888   /* Create a matching rule if the unique name exists (when no
1889      wildcard).  */
1890   if (NILP (uname) || (SBYTES (uname) > 0))
1891     {
1892       /* Open a connection to the bus.  */
1893       connection = xd_initialize (bus, TRUE);
1894
1895       /* Create a rule to receive related signals.  */
1896       sprintf (rule,
1897                "type='signal',interface='%s',member='%s'",
1898                SDATA (interface),
1899                SDATA (signal));
1900
1901       /* Add unique name and path to the rule if they are non-nil.  */
1902       if (!NILP (uname))
1903         {
1904           sprintf (x, ",sender='%s'", SDATA (uname));
1905           strcat (rule, x);
1906         }
1907
1908       if (!NILP (path))
1909         {
1910           sprintf (x, ",path='%s'", SDATA (path));
1911           strcat (rule, x);
1912         }
1913
1914       /* Add arguments to the rule if they are non-nil.  */
1915       for (i = 6; i < nargs; ++i)
1916         if (!NILP (args[i]))
1917           {
1918             CHECK_STRING (args[i]);
1919             sprintf (x, ",arg%d='%s'", i-6, SDATA (args[i]));
1920             strcat (rule, x);
1921           }
1922
1923       /* Add the rule to the bus.  */
1924       dbus_error_init (&derror);
1925       dbus_bus_add_match (connection, rule, &derror);
1926       if (dbus_error_is_set (&derror))
1927         {
1928           UNGCPRO;
1929           XD_ERROR (derror);
1930         }
1931
1932       /* Cleanup.  */
1933       dbus_error_free (&derror);
1934
1935       XD_DEBUG_MESSAGE ("Matching rule \"%s\" created", rule);
1936     }
1937
1938   /* Create a hash table entry.  */
1939   key = list3 (bus, interface, signal);
1940   key1 = list4 (uname, service, path, handler);
1941   value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1942
1943   if (NILP (Fmember (key1, value)))
1944     Fputhash (key, Fcons (key1, value), Vdbus_registered_objects_table);
1945
1946   /* Return object.  */
1947   RETURN_UNGCPRO (list2 (key, list3 (service, path, handler)));
1948 }
1949
1950 DEFUN ("dbus-register-method", Fdbus_register_method, Sdbus_register_method,
1951        6, 6, 0,
1952        doc: /* Register for method METHOD on the D-Bus BUS.
1953
1954 BUS is either a Lisp symbol, `:system' or `:session', or a string
1955 denoting the bus address.
1956
1957 SERVICE is the D-Bus service name of the D-Bus object METHOD is
1958 registered for.  It must be a known name.
1959
1960 PATH is the D-Bus object path SERVICE is registered.  INTERFACE is the
1961 interface offered by SERVICE.  It must provide METHOD.  HANDLER is a
1962 Lisp function to be called when a method call is received.  It must
1963 accept the input arguments of METHOD.  The return value of HANDLER is
1964 used for composing the returning D-Bus message.  */)
1965   (Lisp_Object bus, Lisp_Object service, Lisp_Object path, Lisp_Object interface, Lisp_Object method, Lisp_Object handler)
1966 {
1967   Lisp_Object key, key1, value;
1968   DBusConnection *connection;
1969   int result;
1970   DBusError derror;
1971
1972   /* Check parameters.  */
1973   CHECK_STRING (service);
1974   CHECK_STRING (path);
1975   CHECK_STRING (interface);
1976   CHECK_STRING (method);
1977   if (!FUNCTIONP (handler))
1978     wrong_type_argument (intern ("functionp"), handler);
1979   /* TODO: We must check for a valid service name, otherwise there is
1980      a segmentation fault.  */
1981
1982   /* Open a connection to the bus.  */
1983   connection = xd_initialize (bus, TRUE);
1984
1985   /* Request the known name from the bus.  We can ignore the result,
1986      it is set to -1 if there is an error - kind of redundancy.  */
1987   dbus_error_init (&derror);
1988   result = dbus_bus_request_name (connection, SDATA (service), 0, &derror);
1989   if (dbus_error_is_set (&derror))
1990     XD_ERROR (derror);
1991
1992   /* Create a hash table entry.  We use nil for the unique name,
1993      because the method might be called from anybody.  */
1994   key = list3 (bus, interface, method);
1995   key1 = list4 (Qnil, service, path, handler);
1996   value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1997
1998   if (NILP (Fmember (key1, value)))
1999     Fputhash (key, Fcons (key1, value), Vdbus_registered_objects_table);
2000
2001   /* Cleanup.  */
2002   dbus_error_free (&derror);
2003
2004   /* Return object.  */
2005   return list2 (key, list3 (service, path, handler));
2006 }
2007
2008 \f
2009 void
2010 syms_of_dbusbind (void)
2011 {
2012
2013   Qdbus_init_bus = intern_c_string ("dbus-init-bus");
2014   staticpro (&Qdbus_init_bus);
2015   defsubr (&Sdbus_init_bus);
2016
2017   Qdbus_close_bus = intern_c_string ("dbus-close-bus");
2018   staticpro (&Qdbus_close_bus);
2019   defsubr (&Sdbus_close_bus);
2020
2021   Qdbus_get_unique_name = intern_c_string ("dbus-get-unique-name");
2022   staticpro (&Qdbus_get_unique_name);
2023   defsubr (&Sdbus_get_unique_name);
2024
2025   Qdbus_call_method = intern_c_string ("dbus-call-method");
2026   staticpro (&Qdbus_call_method);
2027   defsubr (&Sdbus_call_method);
2028
2029   Qdbus_call_method_asynchronously = intern_c_string ("dbus-call-method-asynchronously");
2030   staticpro (&Qdbus_call_method_asynchronously);
2031   defsubr (&Sdbus_call_method_asynchronously);
2032
2033   Qdbus_method_return_internal = intern_c_string ("dbus-method-return-internal");
2034   staticpro (&Qdbus_method_return_internal);
2035   defsubr (&Sdbus_method_return_internal);
2036
2037   Qdbus_method_error_internal = intern_c_string ("dbus-method-error-internal");
2038   staticpro (&Qdbus_method_error_internal);
2039   defsubr (&Sdbus_method_error_internal);
2040
2041   Qdbus_send_signal = intern_c_string ("dbus-send-signal");
2042   staticpro (&Qdbus_send_signal);
2043   defsubr (&Sdbus_send_signal);
2044
2045   Qdbus_register_signal = intern_c_string ("dbus-register-signal");
2046   staticpro (&Qdbus_register_signal);
2047   defsubr (&Sdbus_register_signal);
2048
2049   Qdbus_register_method = intern_c_string ("dbus-register-method");
2050   staticpro (&Qdbus_register_method);
2051   defsubr (&Sdbus_register_method);
2052
2053   Qdbus_error = intern_c_string ("dbus-error");
2054   staticpro (&Qdbus_error);
2055   Fput (Qdbus_error, Qerror_conditions,
2056         list2 (Qdbus_error, Qerror));
2057   Fput (Qdbus_error, Qerror_message,
2058         make_pure_c_string ("D-Bus error"));
2059
2060   QCdbus_system_bus = intern_c_string (":system");
2061   staticpro (&QCdbus_system_bus);
2062
2063   QCdbus_session_bus = intern_c_string (":session");
2064   staticpro (&QCdbus_session_bus);
2065
2066   QCdbus_timeout = intern_c_string (":timeout");
2067   staticpro (&QCdbus_timeout);
2068
2069   QCdbus_type_byte = intern_c_string (":byte");
2070   staticpro (&QCdbus_type_byte);
2071
2072   QCdbus_type_boolean = intern_c_string (":boolean");
2073   staticpro (&QCdbus_type_boolean);
2074
2075   QCdbus_type_int16 = intern_c_string (":int16");
2076   staticpro (&QCdbus_type_int16);
2077
2078   QCdbus_type_uint16 = intern_c_string (":uint16");
2079   staticpro (&QCdbus_type_uint16);
2080
2081   QCdbus_type_int32 = intern_c_string (":int32");
2082   staticpro (&QCdbus_type_int32);
2083
2084   QCdbus_type_uint32 = intern_c_string (":uint32");
2085   staticpro (&QCdbus_type_uint32);
2086
2087   QCdbus_type_int64 = intern_c_string (":int64");
2088   staticpro (&QCdbus_type_int64);
2089
2090   QCdbus_type_uint64 = intern_c_string (":uint64");
2091   staticpro (&QCdbus_type_uint64);
2092
2093   QCdbus_type_double = intern_c_string (":double");
2094   staticpro (&QCdbus_type_double);
2095
2096   QCdbus_type_string = intern_c_string (":string");
2097   staticpro (&QCdbus_type_string);
2098
2099   QCdbus_type_object_path = intern_c_string (":object-path");
2100   staticpro (&QCdbus_type_object_path);
2101
2102   QCdbus_type_signature = intern_c_string (":signature");
2103   staticpro (&QCdbus_type_signature);
2104
2105   QCdbus_type_array = intern_c_string (":array");
2106   staticpro (&QCdbus_type_array);
2107
2108   QCdbus_type_variant = intern_c_string (":variant");
2109   staticpro (&QCdbus_type_variant);
2110
2111   QCdbus_type_struct = intern_c_string (":struct");
2112   staticpro (&QCdbus_type_struct);
2113
2114   QCdbus_type_dict_entry = intern_c_string (":dict-entry");
2115   staticpro (&QCdbus_type_dict_entry);
2116
2117   DEFVAR_LISP ("dbus-registered-buses",
2118                &Vdbus_registered_buses,
2119     doc: /* List of D-Bus buses we are polling for messages.  */);
2120   Vdbus_registered_buses = Qnil;
2121
2122   DEFVAR_LISP ("dbus-registered-objects-table",
2123                &Vdbus_registered_objects_table,
2124     doc: /* Hash table of registered functions for D-Bus.
2125
2126 There are two different uses of the hash table: for accessing
2127 registered interfaces properties, targeted by signals or method calls,
2128 and for calling handlers in case of non-blocking method call returns.
2129
2130 In the first case, the key in the hash table is the list (BUS
2131 INTERFACE MEMBER).  BUS is either a Lisp symbol, `:system' or
2132 `:session', or a string denoting the bus address.  INTERFACE is a
2133 string which denotes a D-Bus interface, and MEMBER, also a string, is
2134 either a method, a signal or a property INTERFACE is offering.  All
2135 arguments but BUS must not be nil.
2136
2137 The value in the hash table is a list of quadruple lists
2138 \((UNAME SERVICE PATH OBJECT) (UNAME SERVICE PATH OBJECT) ...).
2139 SERVICE is the service name as registered, UNAME is the corresponding
2140 unique name.  In case of registered methods and properties, UNAME is
2141 nil.  PATH is the object path of the sending object.  All of them can
2142 be nil, which means a wildcard then.  OBJECT is either the handler to
2143 be called when a D-Bus message, which matches the key criteria,
2144 arrives (methods and signals), or a cons cell containing the value of
2145 the property.
2146
2147 In the second case, the key in the hash table is the list (BUS
2148 SERIAL).  BUS is either a Lisp symbol, `:system' or `:session', or a
2149 string denoting the bus address.  SERIAL is the serial number of the
2150 non-blocking method call, a reply is expected.  Both arguments must
2151 not be nil.  The value in the hash table is HANDLER, the function to
2152 be called when the D-Bus reply message arrives.  */);
2153   {
2154     Lisp_Object args[2];
2155     args[0] = QCtest;
2156     args[1] = Qequal;
2157     Vdbus_registered_objects_table = Fmake_hash_table (2, args);
2158   }
2159
2160   DEFVAR_LISP ("dbus-debug", &Vdbus_debug,
2161     doc: /* If non-nil, debug messages of D-Bus bindings are raised.  */);
2162 #ifdef DBUS_DEBUG
2163   Vdbus_debug = Qt;
2164   /* We can also set environment DBUS_VERBOSE=1 in order to see more
2165      traces.  */
2166 #else
2167   Vdbus_debug = Qnil;
2168   /* We do not want to abort.  */
2169   setenv ("DBUS_FATAL_WARNINGS", "0", 1);
2170 #endif
2171
2172   Fprovide (intern_c_string ("dbusbind"), Qnil);
2173
2174 }
2175
2176 #endif /* HAVE_DBUS */
2177
2178 /* arch-tag: 0e828477-b571-4fe4-b559-5c9211bc14b8
2179    (do not change this comment) */