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