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   /* Check dbus-registered-objects-table.  */
1179   if (!HASH_TABLE_P (Vdbus_registered_objects_table))
1180     XD_SIGNAL1 (build_string ("dbus.el is not loaded"));
1181
1182   /* Open a connection to the bus.  */
1183   connection = xd_initialize (bus);
1184
1185   /* Create the message.  */
1186   dmessage = dbus_message_new_method_call (SDATA (service),
1187                                            SDATA (path),
1188                                            SDATA (interface),
1189                                            SDATA (method));
1190   if (dmessage == NULL)
1191     XD_SIGNAL1 (build_string ("Unable to create a new message"));
1192
1193   /* Check for timeout parameter.  */
1194   if ((i+2 <= nargs) && (EQ ((args[i]), QCdbus_timeout)))
1195     {
1196       CHECK_NATNUM (args[i+1]);
1197       timeout = XUINT (args[i+1]);
1198       i = i+2;
1199     }
1200
1201   /* Initialize parameter list of message.  */
1202   dbus_message_iter_init_append (dmessage, &iter);
1203
1204   /* Append parameters to the message.  */
1205   for (; i < nargs; ++i)
1206     {
1207       dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1208       if (XD_DBUS_TYPE_P (args[i]))
1209         {
1210           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1211           XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1212           XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-4,
1213                             SDATA (format2 ("%s", args[i], Qnil)),
1214                             SDATA (format2 ("%s", args[i+1], Qnil)));
1215           ++i;
1216         }
1217       else
1218         {
1219           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1220           XD_DEBUG_MESSAGE ("Parameter%d %s", i-4,
1221                             SDATA (format2 ("%s", args[i], Qnil)));
1222         }
1223
1224       /* Check for valid signature.  We use DBUS_TYPE_INVALID as
1225          indication that there is no parent type.  */
1226       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1227
1228       xd_append_arg (dtype, args[i], &iter);
1229     }
1230
1231   if (!NILP (handler))
1232     {
1233       /* Send the message.  The message is just added to the outgoing
1234          message queue.  */
1235       if (!dbus_connection_send_with_reply (connection, dmessage,
1236                                             NULL, timeout))
1237         XD_SIGNAL1 (build_string ("Cannot send message"));
1238
1239       /* The result is the key in Vdbus_registered_objects_table.  */
1240       result = (list2 (bus, make_number (dbus_message_get_serial (dmessage))));
1241
1242       /* Create a hash table entry.  */
1243       Fputhash (result, handler, Vdbus_registered_objects_table);
1244     }
1245   else
1246     {
1247       /* Send the message.  The message is just added to the outgoing
1248          message queue.  */
1249       if (!dbus_connection_send (connection, dmessage, NULL))
1250         XD_SIGNAL1 (build_string ("Cannot send message"));
1251
1252       result = Qnil;
1253     }
1254
1255   /* Flush connection to ensure the message is handled.  */
1256   dbus_connection_flush (connection);
1257
1258   XD_DEBUG_MESSAGE ("Message sent");
1259
1260   /* Cleanup.  */
1261   dbus_message_unref (dmessage);
1262
1263   /* Return the result.  */
1264   RETURN_UNGCPRO (result);
1265 }
1266
1267 DEFUN ("dbus-method-return-internal", Fdbus_method_return_internal,
1268        Sdbus_method_return_internal,
1269        3, MANY, 0,
1270        doc: /* Return for message SERIAL on the D-Bus BUS.
1271 This is an internal function, it shall not be used outside dbus.el.
1272
1273 usage: (dbus-method-return-internal BUS SERIAL SERVICE &rest ARGS)  */)
1274      (nargs, args)
1275      int nargs;
1276      register Lisp_Object *args;
1277 {
1278   Lisp_Object bus, serial, service;
1279   struct gcpro gcpro1, gcpro2, gcpro3;
1280   DBusConnection *connection;
1281   DBusMessage *dmessage;
1282   DBusMessageIter iter;
1283   unsigned int dtype;
1284   int i;
1285   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1286
1287   /* Check parameters.  */
1288   bus = args[0];
1289   serial = args[1];
1290   service = args[2];
1291
1292   CHECK_SYMBOL (bus);
1293   CHECK_NUMBER (serial);
1294   CHECK_STRING (service);
1295   GCPRO3 (bus, serial, service);
1296
1297   XD_DEBUG_MESSAGE ("%lu %s ", (unsigned long) XUINT (serial), SDATA (service));
1298
1299   /* Open a connection to the bus.  */
1300   connection = xd_initialize (bus);
1301
1302   /* Create the message.  */
1303   dmessage = dbus_message_new (DBUS_MESSAGE_TYPE_METHOD_RETURN);
1304   if ((dmessage == NULL)
1305       || (!dbus_message_set_reply_serial (dmessage, XUINT (serial)))
1306       || (!dbus_message_set_destination (dmessage, SDATA (service))))
1307     {
1308       UNGCPRO;
1309       XD_SIGNAL1 (build_string ("Unable to create a return message"));
1310     }
1311
1312   UNGCPRO;
1313
1314   /* Initialize parameter list of message.  */
1315   dbus_message_iter_init_append (dmessage, &iter);
1316
1317   /* Append parameters to the message.  */
1318   for (i = 3; i < nargs; ++i)
1319     {
1320       dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1321       if (XD_DBUS_TYPE_P (args[i]))
1322         {
1323           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1324           XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1325           XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-2,
1326                             SDATA (format2 ("%s", args[i], Qnil)),
1327                             SDATA (format2 ("%s", args[i+1], Qnil)));
1328           ++i;
1329         }
1330       else
1331         {
1332           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1333           XD_DEBUG_MESSAGE ("Parameter%d %s", i-2,
1334                             SDATA (format2 ("%s", args[i], Qnil)));
1335         }
1336
1337       /* Check for valid signature.  We use DBUS_TYPE_INVALID as
1338          indication that there is no parent type.  */
1339       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1340
1341       xd_append_arg (dtype, args[i], &iter);
1342     }
1343
1344   /* Send the message.  The message is just added to the outgoing
1345      message queue.  */
1346   if (!dbus_connection_send (connection, dmessage, NULL))
1347     XD_SIGNAL1 (build_string ("Cannot send message"));
1348
1349   /* Flush connection to ensure the message is handled.  */
1350   dbus_connection_flush (connection);
1351
1352   XD_DEBUG_MESSAGE ("Message sent");
1353
1354   /* Cleanup.  */
1355   dbus_message_unref (dmessage);
1356
1357   /* Return.  */
1358   return Qt;
1359 }
1360
1361 DEFUN ("dbus-method-error-internal", Fdbus_method_error_internal,
1362        Sdbus_method_error_internal,
1363        3, MANY, 0,
1364        doc: /* Return error message for message SERIAL on the D-Bus BUS.
1365 This is an internal function, it shall not be used outside dbus.el.
1366
1367 usage: (dbus-method-error-internal BUS SERIAL SERVICE &rest ARGS)  */)
1368      (nargs, args)
1369      int nargs;
1370      register Lisp_Object *args;
1371 {
1372   Lisp_Object bus, serial, service;
1373   struct gcpro gcpro1, gcpro2, gcpro3;
1374   DBusConnection *connection;
1375   DBusMessage *dmessage;
1376   DBusMessageIter iter;
1377   unsigned int dtype;
1378   int i;
1379   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1380
1381   /* Check parameters.  */
1382   bus = args[0];
1383   serial = args[1];
1384   service = args[2];
1385
1386   CHECK_SYMBOL (bus);
1387   CHECK_NUMBER (serial);
1388   CHECK_STRING (service);
1389   GCPRO3 (bus, serial, service);
1390
1391   XD_DEBUG_MESSAGE ("%lu %s ", (unsigned long) XUINT (serial), SDATA (service));
1392
1393   /* Open a connection to the bus.  */
1394   connection = xd_initialize (bus);
1395
1396   /* Create the message.  */
1397   dmessage = dbus_message_new (DBUS_MESSAGE_TYPE_ERROR);
1398   if ((dmessage == NULL)
1399       || (!dbus_message_set_error_name (dmessage, DBUS_ERROR_FAILED))
1400       || (!dbus_message_set_reply_serial (dmessage, XUINT (serial)))
1401       || (!dbus_message_set_destination (dmessage, SDATA (service))))
1402     {
1403       UNGCPRO;
1404       XD_SIGNAL1 (build_string ("Unable to create a error message"));
1405     }
1406
1407   UNGCPRO;
1408
1409   /* Initialize parameter list of message.  */
1410   dbus_message_iter_init_append (dmessage, &iter);
1411
1412   /* Append parameters to the message.  */
1413   for (i = 3; i < nargs; ++i)
1414     {
1415       dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1416       if (XD_DBUS_TYPE_P (args[i]))
1417         {
1418           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1419           XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1420           XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-2,
1421                             SDATA (format2 ("%s", args[i], Qnil)),
1422                             SDATA (format2 ("%s", args[i+1], Qnil)));
1423           ++i;
1424         }
1425       else
1426         {
1427           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1428           XD_DEBUG_MESSAGE ("Parameter%d %s", i-2,
1429                             SDATA (format2 ("%s", args[i], Qnil)));
1430         }
1431
1432       /* Check for valid signature.  We use DBUS_TYPE_INVALID as
1433          indication that there is no parent type.  */
1434       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1435
1436       xd_append_arg (dtype, args[i], &iter);
1437     }
1438
1439   /* Send the message.  The message is just added to the outgoing
1440      message queue.  */
1441   if (!dbus_connection_send (connection, dmessage, NULL))
1442     XD_SIGNAL1 (build_string ("Cannot send message"));
1443
1444   /* Flush connection to ensure the message is handled.  */
1445   dbus_connection_flush (connection);
1446
1447   XD_DEBUG_MESSAGE ("Message sent");
1448
1449   /* Cleanup.  */
1450   dbus_message_unref (dmessage);
1451
1452   /* Return.  */
1453   return Qt;
1454 }
1455
1456 DEFUN ("dbus-send-signal", Fdbus_send_signal, Sdbus_send_signal, 5, MANY, 0,
1457        doc: /* Send signal SIGNAL on the D-Bus BUS.
1458
1459 BUS is either the symbol `:system' or the symbol `:session'.
1460
1461 SERVICE is the D-Bus service name SIGNAL is sent from.  PATH is the
1462 D-Bus object path SERVICE is registered at.  INTERFACE is an interface
1463 offered by SERVICE.  It must provide signal SIGNAL.
1464
1465 All other arguments ARGS are passed to SIGNAL as arguments.  They are
1466 converted into D-Bus types via the following rules:
1467
1468   t and nil => DBUS_TYPE_BOOLEAN
1469   number    => DBUS_TYPE_UINT32
1470   integer   => DBUS_TYPE_INT32
1471   float     => DBUS_TYPE_DOUBLE
1472   string    => DBUS_TYPE_STRING
1473   list      => DBUS_TYPE_ARRAY
1474
1475 All arguments can be preceded by a type symbol.  For details about
1476 type symbols, see Info node `(dbus)Type Conversion'.
1477
1478 Example:
1479
1480 \(dbus-send-signal
1481   :session "org.gnu.Emacs" "/org/gnu/Emacs"
1482   "org.gnu.Emacs.FileManager" "FileModified" "/home/albinus/.emacs")
1483
1484 usage: (dbus-send-signal BUS SERVICE PATH INTERFACE SIGNAL &rest ARGS)  */)
1485      (nargs, args)
1486      int nargs;
1487      register Lisp_Object *args;
1488 {
1489   Lisp_Object bus, service, path, interface, signal;
1490   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
1491   DBusConnection *connection;
1492   DBusMessage *dmessage;
1493   DBusMessageIter iter;
1494   unsigned int dtype;
1495   int i;
1496   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1497
1498   /* Check parameters.  */
1499   bus = args[0];
1500   service = args[1];
1501   path = args[2];
1502   interface = args[3];
1503   signal = args[4];
1504
1505   CHECK_SYMBOL (bus);
1506   CHECK_STRING (service);
1507   CHECK_STRING (path);
1508   CHECK_STRING (interface);
1509   CHECK_STRING (signal);
1510   GCPRO5 (bus, service, path, interface, signal);
1511
1512   XD_DEBUG_MESSAGE ("%s %s %s %s",
1513                     SDATA (service),
1514                     SDATA (path),
1515                     SDATA (interface),
1516                     SDATA (signal));
1517
1518   /* Open a connection to the bus.  */
1519   connection = xd_initialize (bus);
1520
1521   /* Create the message.  */
1522   dmessage = dbus_message_new_signal (SDATA (path),
1523                                       SDATA (interface),
1524                                       SDATA (signal));
1525   UNGCPRO;
1526   if (dmessage == NULL)
1527     XD_SIGNAL1 (build_string ("Unable to create a new message"));
1528
1529   /* Initialize parameter list of message.  */
1530   dbus_message_iter_init_append (dmessage, &iter);
1531
1532   /* Append parameters to the message.  */
1533   for (i = 5; i < nargs; ++i)
1534     {
1535       dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1536       if (XD_DBUS_TYPE_P (args[i]))
1537         {
1538           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1539           XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1540           XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-4,
1541                             SDATA (format2 ("%s", args[i], Qnil)),
1542                             SDATA (format2 ("%s", args[i+1], Qnil)));
1543           ++i;
1544         }
1545       else
1546         {
1547           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1548           XD_DEBUG_MESSAGE ("Parameter%d %s", i-4,
1549                             SDATA (format2 ("%s", args[i], Qnil)));
1550         }
1551
1552       /* Check for valid signature.  We use DBUS_TYPE_INVALID as
1553          indication that there is no parent type.  */
1554       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1555
1556       xd_append_arg (dtype, args[i], &iter);
1557     }
1558
1559   /* Send the message.  The message is just added to the outgoing
1560      message queue.  */
1561   if (!dbus_connection_send (connection, dmessage, NULL))
1562     XD_SIGNAL1 (build_string ("Cannot send message"));
1563
1564   /* Flush connection to ensure the message is handled.  */
1565   dbus_connection_flush (connection);
1566
1567   XD_DEBUG_MESSAGE ("Signal sent");
1568
1569   /* Cleanup.  */
1570   dbus_message_unref (dmessage);
1571
1572   /* Return.  */
1573   return Qt;
1574 }
1575
1576 /* Check, whether there is pending input in the message queue of the
1577    D-Bus BUS.  BUS is a Lisp symbol, either :system or :session.  */
1578 static Lisp_Object
1579 xd_get_dispatch_status (bus)
1580      Lisp_Object bus;
1581 {
1582   DBusConnection *connection;
1583
1584   /* Open a connection to the bus.  */
1585   connection = xd_initialize (bus);
1586
1587   /* Non blocking read of the next available message.  */
1588   dbus_connection_read_write (connection, 0);
1589
1590   /* Return.  */
1591   return
1592     (dbus_connection_get_dispatch_status (connection)
1593      == DBUS_DISPATCH_DATA_REMAINS)
1594     ? Qt : Qnil;
1595 }
1596
1597 /* Check for queued incoming messages from the system and session buses.  */
1598 int
1599 xd_pending_messages ()
1600 {
1601   int ret = FALSE;
1602   xd_in_read_queued_messages = 1;
1603
1604   /* Vdbus_registered_objects_table will be initialized as hash table
1605      in dbus.el.  When this package isn't loaded yet, it doesn't make
1606      sense to handle D-Bus messages.  */
1607   if (HASH_TABLE_P (Vdbus_registered_objects_table))
1608     {
1609       ret = (!NILP (internal_catch (Qdbus_error, xd_get_dispatch_status,
1610                                     QCdbus_system_bus)));
1611       if (ret) goto theend;
1612
1613       ret = ((getenv ("DBUS_SESSION_BUS_ADDRESS") != NULL) &&
1614              (!NILP (internal_catch (Qdbus_error, xd_get_dispatch_status,
1615                                      QCdbus_session_bus))));
1616     }
1617
1618   /* Return.  */
1619  theend:
1620   xd_in_read_queued_messages = 0;
1621   return ret;
1622 }
1623
1624 /* Read queued incoming message of the D-Bus BUS.  BUS is a Lisp
1625    symbol, either :system or :session.  */
1626 static Lisp_Object
1627 xd_read_message (bus)
1628      Lisp_Object bus;
1629 {
1630   Lisp_Object args, key, value;
1631   struct gcpro gcpro1;
1632   struct input_event event;
1633   DBusConnection *connection;
1634   DBusMessage *dmessage;
1635   DBusMessageIter iter;
1636   unsigned int dtype;
1637   int mtype, serial;
1638   const char *uname, *path, *interface, *member;
1639
1640   /* Open a connection to the bus.  */
1641   connection = xd_initialize (bus);
1642
1643   /* Non blocking read of the next available message.  */
1644   dbus_connection_read_write (connection, 0);
1645   dmessage = dbus_connection_pop_message (connection);
1646
1647   /* Return if there is no queued message.  */
1648   if (dmessage == NULL)
1649     return Qnil;
1650
1651   /* Collect the parameters.  */
1652   args = Qnil;
1653   GCPRO1 (args);
1654
1655   /* Loop over the resulting parameters.  Construct a list.  */
1656   if (dbus_message_iter_init (dmessage, &iter))
1657     {
1658       while ((dtype = dbus_message_iter_get_arg_type (&iter))
1659              != DBUS_TYPE_INVALID)
1660         {
1661           args = Fcons (xd_retrieve_arg (dtype, &iter), args);
1662           dbus_message_iter_next (&iter);
1663         }
1664       /* The arguments are stored in reverse order.  Reorder them.  */
1665       args = Fnreverse (args);
1666     }
1667
1668   /* Read message type, message serial, unique name, object path,
1669      interface and member from the message.  */
1670   mtype = dbus_message_get_type (dmessage);
1671   serial =
1672     ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1673      || (mtype == DBUS_MESSAGE_TYPE_ERROR))
1674     ? dbus_message_get_reply_serial (dmessage)
1675     : dbus_message_get_serial (dmessage);
1676   uname = dbus_message_get_sender (dmessage);
1677   path = dbus_message_get_path (dmessage);
1678   interface = dbus_message_get_interface (dmessage);
1679   member = dbus_message_get_member (dmessage);
1680
1681   XD_DEBUG_MESSAGE ("Event received: %s %d %s %s %s %s %s",
1682                     (mtype == DBUS_MESSAGE_TYPE_INVALID)
1683                     ? "DBUS_MESSAGE_TYPE_INVALID"
1684                     : (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1685                     ? "DBUS_MESSAGE_TYPE_METHOD_CALL"
1686                     : (mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1687                     ? "DBUS_MESSAGE_TYPE_METHOD_RETURN"
1688                     : (mtype == DBUS_MESSAGE_TYPE_ERROR)
1689                     ? "DBUS_MESSAGE_TYPE_ERROR"
1690                     : "DBUS_MESSAGE_TYPE_SIGNAL",
1691                     serial, uname, path, interface, member,
1692                     SDATA (format2 ("%s", args, Qnil)));
1693
1694   if ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1695       || (mtype == DBUS_MESSAGE_TYPE_ERROR))
1696     {
1697       /* Search for a registered function of the message.  */
1698       key = list2 (bus, make_number (serial));
1699       value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1700
1701       /* There shall be exactly one entry.  Construct an event.  */
1702       if (NILP (value))
1703         goto cleanup;
1704
1705       /* Remove the entry.  */
1706       Fremhash (key, Vdbus_registered_objects_table);
1707
1708       /* Construct an event.  */
1709       EVENT_INIT (event);
1710       event.kind = DBUS_EVENT;
1711       event.frame_or_window = Qnil;
1712       event.arg = Fcons (value, args);
1713     }
1714
1715   else /* (mtype != DBUS_MESSAGE_TYPE_METHOD_RETURN)  */
1716     {
1717       /* Vdbus_registered_objects_table requires non-nil interface and
1718          member.  */
1719       if ((interface == NULL) || (member == NULL))
1720         goto cleanup;
1721
1722       /* Search for a registered function of the message.  */
1723       key = list3 (bus, build_string (interface), build_string (member));
1724       value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1725
1726       /* Loop over the registered functions.  Construct an event.  */
1727       while (!NILP (value))
1728         {
1729           key = CAR_SAFE (value);
1730           /* key has the structure (UNAME SERVICE PATH HANDLER).  */
1731           if (((uname == NULL)
1732                || (NILP (CAR_SAFE (key)))
1733                || (strcmp (uname, SDATA (CAR_SAFE (key))) == 0))
1734               && ((path == NULL)
1735                   || (NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1736                   || (strcmp (path,
1737                               SDATA (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1738                       == 0))
1739               && (!NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))))))
1740             {
1741               EVENT_INIT (event);
1742               event.kind = DBUS_EVENT;
1743               event.frame_or_window = Qnil;
1744               event.arg = Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))),
1745                                  args);
1746               break;
1747             }
1748           value = CDR_SAFE (value);
1749         }
1750
1751       if (NILP (value))
1752         goto cleanup;
1753     }
1754
1755   /* Add type, serial, uname, path, interface and member to the event.  */
1756   event.arg = Fcons ((member == NULL ? Qnil : build_string (member)),
1757                      event.arg);
1758   event.arg = Fcons ((interface == NULL ? Qnil : build_string (interface)),
1759                      event.arg);
1760   event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
1761                      event.arg);
1762   event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
1763                      event.arg);
1764   event.arg = Fcons (make_number (serial), event.arg);
1765   event.arg = Fcons (make_number (mtype), event.arg);
1766
1767   /* Add the bus symbol to the event.  */
1768   event.arg = Fcons (bus, event.arg);
1769
1770   /* Store it into the input event queue.  */
1771   kbd_buffer_store_event (&event);
1772
1773   XD_DEBUG_MESSAGE ("Event stored: %s",
1774                     SDATA (format2 ("%s", event.arg, Qnil)));
1775
1776   /* Cleanup.  */
1777  cleanup:
1778   dbus_message_unref (dmessage);
1779
1780   RETURN_UNGCPRO (Qnil);
1781 }
1782
1783 /* Read queued incoming messages from the system and session buses.  */
1784 void
1785 xd_read_queued_messages ()
1786 {
1787
1788   /* Vdbus_registered_objects_table will be initialized as hash table
1789      in dbus.el.  When this package isn't loaded yet, it doesn't make
1790      sense to handle D-Bus messages.  Furthermore, we ignore all Lisp
1791      errors during the call.  */
1792   if (HASH_TABLE_P (Vdbus_registered_objects_table))
1793     {
1794       xd_in_read_queued_messages = 1;
1795       internal_catch (Qdbus_error, xd_read_message, QCdbus_system_bus);
1796       internal_catch (Qdbus_error, xd_read_message, QCdbus_session_bus);
1797       xd_in_read_queued_messages = 0;
1798     }
1799 }
1800
1801 DEFUN ("dbus-register-signal", Fdbus_register_signal, Sdbus_register_signal,
1802        6, MANY, 0,
1803        doc: /* Register for signal SIGNAL on the D-Bus BUS.
1804
1805 BUS is either the symbol `:system' or the symbol `:session'.
1806
1807 SERVICE is the D-Bus service name used by the sending D-Bus object.
1808 It can be either a known name or the unique name of the D-Bus object
1809 sending the signal.  When SERVICE is nil, related signals from all
1810 D-Bus objects shall be accepted.
1811
1812 PATH is the D-Bus object path SERVICE is registered.  It can also be
1813 nil if the path name of incoming signals shall not be checked.
1814
1815 INTERFACE is an interface offered by SERVICE.  It must provide SIGNAL.
1816 HANDLER is a Lisp function to be called when the signal is received.
1817 It must accept as arguments the values SIGNAL is sending.
1818
1819 All other arguments ARGS, if specified, must be strings.  They stand
1820 for the respective arguments of the signal in their order, and are
1821 used for filtering as well.  A nil argument might be used to preserve
1822 the order.
1823
1824 INTERFACE, SIGNAL and HANDLER must not be nil.  Example:
1825
1826 \(defun my-signal-handler (device)
1827   (message "Device %s added" device))
1828
1829 \(dbus-register-signal
1830   :system "org.freedesktop.Hal" "/org/freedesktop/Hal/Manager"
1831   "org.freedesktop.Hal.Manager" "DeviceAdded" 'my-signal-handler)
1832
1833   => ((:system "org.freedesktop.Hal.Manager" "DeviceAdded")
1834       ("org.freedesktop.Hal" "/org/freedesktop/Hal/Manager" my-signal-handler))
1835
1836 `dbus-register-signal' returns an object, which can be used in
1837 `dbus-unregister-object' for removing the registration.
1838
1839 usage: (dbus-register-signal BUS SERVICE PATH INTERFACE SIGNAL HANDLER &rest ARGS) */)
1840      (nargs, args)
1841      int nargs;
1842      register Lisp_Object *args;
1843 {
1844   Lisp_Object bus, service, path, interface, signal, handler;
1845   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5, gcpro6;
1846   Lisp_Object uname, key, key1, value;
1847   DBusConnection *connection;
1848   int i;
1849   char rule[DBUS_MAXIMUM_MATCH_RULE_LENGTH];
1850   char x[DBUS_MAXIMUM_MATCH_RULE_LENGTH];
1851   DBusError derror;
1852
1853   /* Check parameters.  */
1854   bus = args[0];
1855   service = args[1];
1856   path = args[2];
1857   interface = args[3];
1858   signal = args[4];
1859   handler = args[5];
1860
1861   CHECK_SYMBOL (bus);
1862   if (!NILP (service)) CHECK_STRING (service);
1863   if (!NILP (path)) CHECK_STRING (path);
1864   CHECK_STRING (interface);
1865   CHECK_STRING (signal);
1866   if (!FUNCTIONP (handler))
1867     wrong_type_argument (intern ("functionp"), handler);
1868   GCPRO6 (bus, service, path, interface, signal, handler);
1869
1870   /* Check dbus-registered-objects-table.  */
1871   if (!HASH_TABLE_P (Vdbus_registered_objects_table))
1872     XD_SIGNAL1 (build_string ("dbus.el is not loaded"));
1873
1874   /* Retrieve unique name of service.  If service is a known name, we
1875      will register for the corresponding unique name, if any.  Signals
1876      are sent always with the unique name as sender.  Note: the unique
1877      name of "org.freedesktop.DBus" is that string itself.  */
1878   if ((STRINGP (service))
1879       && (SBYTES (service) > 0)
1880       && (strcmp (SDATA (service), DBUS_SERVICE_DBUS) != 0)
1881       && (strncmp (SDATA (service), ":", 1) != 0))
1882     {
1883       uname = call2 (intern ("dbus-get-name-owner"), bus, service);
1884       /* When there is no unique name, we mark it with an empty
1885          string.  */
1886       if (NILP (uname))
1887         uname = empty_unibyte_string;
1888     }
1889   else
1890     uname = service;
1891
1892   /* Create a matching rule if the unique name exists (when no
1893      wildcard).  */
1894   if (NILP (uname) || (SBYTES (uname) > 0))
1895     {
1896       /* Open a connection to the bus.  */
1897       connection = xd_initialize (bus);
1898
1899       /* Create a rule to receive related signals.  */
1900       sprintf (rule,
1901                "type='signal',interface='%s',member='%s'",
1902                SDATA (interface),
1903                SDATA (signal));
1904
1905       /* Add unique name and path to the rule if they are non-nil.  */
1906       if (!NILP (uname))
1907         {
1908           sprintf (x, ",sender='%s'", SDATA (uname));
1909           strcat (rule, x);
1910         }
1911
1912       if (!NILP (path))
1913         {
1914           sprintf (x, ",path='%s'", SDATA (path));
1915           strcat (rule, x);
1916         }
1917
1918       /* Add arguments to the rule if they are non-nil.  */
1919       for (i = 6; i < nargs; ++i)
1920         if (!NILP (args[i]))
1921           {
1922             CHECK_STRING (args[i]);
1923             sprintf (x, ",arg%d='%s'", i-6, SDATA (args[i]));
1924             strcat (rule, x);
1925           }
1926
1927       /* Add the rule to the bus.  */
1928       dbus_error_init (&derror);
1929       dbus_bus_add_match (connection, rule, &derror);
1930       if (dbus_error_is_set (&derror))
1931         {
1932           UNGCPRO;
1933           XD_ERROR (derror);
1934         }
1935
1936       /* Cleanup.  */
1937       dbus_error_free (&derror);
1938
1939       XD_DEBUG_MESSAGE ("Matching rule \"%s\" created", rule);
1940     }
1941
1942   /* Create a hash table entry.  */
1943   key = list3 (bus, interface, signal);
1944   key1 = list4 (uname, service, path, handler);
1945   value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1946
1947   if (NILP (Fmember (key1, value)))
1948     Fputhash (key, Fcons (key1, value), Vdbus_registered_objects_table);
1949
1950   /* Return object.  */
1951   RETURN_UNGCPRO (list2 (key, list3 (service, path, handler)));
1952 }
1953
1954 DEFUN ("dbus-register-method", Fdbus_register_method, Sdbus_register_method,
1955        6, 6, 0,
1956        doc: /* Register for method METHOD on the D-Bus BUS.
1957
1958 BUS is either the symbol `:system' or the symbol `:session'.
1959
1960 SERVICE is the D-Bus service name of the D-Bus object METHOD is
1961 registered for.  It must be a known name.
1962
1963 PATH is the D-Bus object path SERVICE is registered.  INTERFACE is the
1964 interface offered by SERVICE.  It must provide METHOD.  HANDLER is a
1965 Lisp function to be called when a method call is received.  It must
1966 accept the input arguments of METHOD.  The return value of HANDLER is
1967 used for composing the returning D-Bus message.  */)
1968      (bus, service, path, interface, method, handler)
1969      Lisp_Object bus, service, path, interface, method, handler;
1970 {
1971   Lisp_Object key, key1, value;
1972   DBusConnection *connection;
1973   int result;
1974   DBusError derror;
1975
1976   /* Check parameters.  */
1977   CHECK_SYMBOL (bus);
1978   CHECK_STRING (service);
1979   CHECK_STRING (path);
1980   CHECK_STRING (interface);
1981   CHECK_STRING (method);
1982   if (!FUNCTIONP (handler))
1983     wrong_type_argument (intern ("functionp"), handler);
1984   /* TODO: We must check for a valid service name, otherwise there is
1985      a segmentation fault.  */
1986
1987   /* Check dbus-registered-objects-table.  */
1988   if (!HASH_TABLE_P (Vdbus_registered_objects_table))
1989     XD_SIGNAL1 (build_string ("dbus.el is not loaded"));
1990
1991   /* Open a connection to the bus.  */
1992   connection = xd_initialize (bus);
1993
1994   /* Request the known name from the bus.  We can ignore the result,
1995      it is set to -1 if there is an error - kind of redundancy.  */
1996   dbus_error_init (&derror);
1997   result = dbus_bus_request_name (connection, SDATA (service), 0, &derror);
1998   if (dbus_error_is_set (&derror))
1999     XD_ERROR (derror);
2000
2001   /* Create a hash table entry.  We use nil for the unique name,
2002      because the method might be called from anybody.  */
2003   key = list3 (bus, interface, method);
2004   key1 = list4 (Qnil, service, path, handler);
2005   value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
2006
2007   if (NILP (Fmember (key1, value)))
2008     Fputhash (key, Fcons (key1, value), Vdbus_registered_objects_table);
2009
2010   /* Cleanup.  */
2011   dbus_error_free (&derror);
2012
2013   /* Return object.  */
2014   return list2 (key, list3 (service, path, handler));
2015 }
2016
2017 \f
2018 void
2019 syms_of_dbusbind ()
2020 {
2021
2022   Qdbus_init_bus = intern_c_string ("dbus-init-bus");
2023   staticpro (&Qdbus_init_bus);
2024   defsubr (&Sdbus_init_bus);
2025
2026   Qdbus_get_unique_name = intern_c_string ("dbus-get-unique-name");
2027   staticpro (&Qdbus_get_unique_name);
2028   defsubr (&Sdbus_get_unique_name);
2029
2030   Qdbus_call_method = intern_c_string ("dbus-call-method");
2031   staticpro (&Qdbus_call_method);
2032   defsubr (&Sdbus_call_method);
2033
2034   Qdbus_call_method_asynchronously = intern_c_string ("dbus-call-method-asynchronously");
2035   staticpro (&Qdbus_call_method_asynchronously);
2036   defsubr (&Sdbus_call_method_asynchronously);
2037
2038   Qdbus_method_return_internal = intern_c_string ("dbus-method-return-internal");
2039   staticpro (&Qdbus_method_return_internal);
2040   defsubr (&Sdbus_method_return_internal);
2041
2042   Qdbus_method_error_internal = intern_c_string ("dbus-method-error-internal");
2043   staticpro (&Qdbus_method_error_internal);
2044   defsubr (&Sdbus_method_error_internal);
2045
2046   Qdbus_send_signal = intern_c_string ("dbus-send-signal");
2047   staticpro (&Qdbus_send_signal);
2048   defsubr (&Sdbus_send_signal);
2049
2050   Qdbus_register_signal = intern_c_string ("dbus-register-signal");
2051   staticpro (&Qdbus_register_signal);
2052   defsubr (&Sdbus_register_signal);
2053
2054   Qdbus_register_method = intern_c_string ("dbus-register-method");
2055   staticpro (&Qdbus_register_method);
2056   defsubr (&Sdbus_register_method);
2057
2058   Qdbus_error = intern_c_string ("dbus-error");
2059   staticpro (&Qdbus_error);
2060   Fput (Qdbus_error, Qerror_conditions,
2061         list2 (Qdbus_error, Qerror));
2062   Fput (Qdbus_error, Qerror_message,
2063         make_pure_c_string ("D-Bus error"));
2064
2065   QCdbus_system_bus = intern_c_string (":system");
2066   staticpro (&QCdbus_system_bus);
2067
2068   QCdbus_session_bus = intern_c_string (":session");
2069   staticpro (&QCdbus_session_bus);
2070
2071   QCdbus_timeout = intern_c_string (":timeout");
2072   staticpro (&QCdbus_timeout);
2073
2074   QCdbus_type_byte = intern_c_string (":byte");
2075   staticpro (&QCdbus_type_byte);
2076
2077   QCdbus_type_boolean = intern_c_string (":boolean");
2078   staticpro (&QCdbus_type_boolean);
2079
2080   QCdbus_type_int16 = intern_c_string (":int16");
2081   staticpro (&QCdbus_type_int16);
2082
2083   QCdbus_type_uint16 = intern_c_string (":uint16");
2084   staticpro (&QCdbus_type_uint16);
2085
2086   QCdbus_type_int32 = intern_c_string (":int32");
2087   staticpro (&QCdbus_type_int32);
2088
2089   QCdbus_type_uint32 = intern_c_string (":uint32");
2090   staticpro (&QCdbus_type_uint32);
2091
2092   QCdbus_type_int64 = intern_c_string (":int64");
2093   staticpro (&QCdbus_type_int64);
2094
2095   QCdbus_type_uint64 = intern_c_string (":uint64");
2096   staticpro (&QCdbus_type_uint64);
2097
2098   QCdbus_type_double = intern_c_string (":double");
2099   staticpro (&QCdbus_type_double);
2100
2101   QCdbus_type_string = intern_c_string (":string");
2102   staticpro (&QCdbus_type_string);
2103
2104   QCdbus_type_object_path = intern_c_string (":object-path");
2105   staticpro (&QCdbus_type_object_path);
2106
2107   QCdbus_type_signature = intern_c_string (":signature");
2108   staticpro (&QCdbus_type_signature);
2109
2110   QCdbus_type_array = intern_c_string (":array");
2111   staticpro (&QCdbus_type_array);
2112
2113   QCdbus_type_variant = intern_c_string (":variant");
2114   staticpro (&QCdbus_type_variant);
2115
2116   QCdbus_type_struct = intern_c_string (":struct");
2117   staticpro (&QCdbus_type_struct);
2118
2119   QCdbus_type_dict_entry = intern_c_string (":dict-entry");
2120   staticpro (&QCdbus_type_dict_entry);
2121
2122   DEFVAR_LISP ("dbus-registered-objects-table",
2123                &Vdbus_registered_objects_table,
2124     doc: /* Hash table of registered functions for D-Bus.
2125 There are two different uses of the hash table: for accessing
2126 registered interfaces properties, targeted by signals or method calls,
2127 and for calling handlers in case of non-blocking method call returns.
2128
2129 In the first case, the key in the hash table is the list (BUS
2130 INTERFACE MEMBER).  BUS is either the symbol `:system' or the symbol
2131 `:session'.  INTERFACE is a string which denotes a D-Bus interface,
2132 and MEMBER, also a string, is either a method, a signal or a property
2133 INTERFACE is offering.  All arguments but BUS must not be nil.
2134
2135 The value in the hash table is a list of quadruple lists
2136 \((UNAME SERVICE PATH OBJECT) (UNAME SERVICE PATH OBJECT) ...).
2137 SERVICE is the service name as registered, UNAME is the corresponding
2138 unique name.  In case of registered methods and properties, UNAME is
2139 nil.  PATH is the object path of the sending object.  All of them can
2140 be nil, which means a wildcard then.  OBJECT is either the handler to
2141 be called when a D-Bus message, which matches the key criteria,
2142 arrives (methods and signals), or a cons cell containing the value of
2143 the property.
2144
2145 In the second case, the key in the hash table is the list (BUS SERIAL).
2146 BUS is either the symbol `:system' or the symbol `:session'.  SERIAL
2147 is the serial number of the non-blocking method call, a reply is
2148 expected.  Both arguments must not be nil.  The value in the hash
2149 table is HANDLER, the function to be called when the D-Bus reply
2150 message arrives.  */);
2151   /* We initialize Vdbus_registered_objects_table in dbus.el, because
2152      we need to define a hash table function first.  */
2153   Vdbus_registered_objects_table = Qnil;
2154
2155   DEFVAR_LISP ("dbus-debug", &Vdbus_debug,
2156     doc: /* If non-nil, debug messages of D-Bus bindings are raised.  */);
2157 #ifdef DBUS_DEBUG
2158   Vdbus_debug = Qt;
2159   /* We can also set environment variable DBUS_VERBOSE=1 in order to
2160      see more traces.  This requires libdbus-1 to be configured with
2161      --enable-verbose-mode.  */
2162 #else
2163   Vdbus_debug = Qnil;
2164 #endif
2165
2166   Fprovide (intern_c_string ("dbusbind"), Qnil);
2167
2168 }
2169
2170 #endif /* HAVE_DBUS */
2171
2172 /* arch-tag: 0e828477-b571-4fe4-b559-5c9211bc14b8
2173    (do not change this comment) */