src/dbusbind.c

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