src/dbusbind.c

   1 /* Elisp bindings for D-Bus.
   2    Copyright (C) 2007 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, or (at your option)
   9 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; see the file COPYING.  If not, write to
  18 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  19 Boston, MA 02110-1301, USA.  */
  20
  21 #include "config.h"
  22
  23 #ifdef HAVE_DBUS
  24 #include <stdlib.h>
  25 #include <stdio.h>
  26 #include <dbus/dbus.h>
  27 #include "lisp.h"
  28 #include "frame.h"
  29 #include "termhooks.h"
  30 #include "keyboard.h"
  31
  32 \f
  33 /* Subroutines.  */
  34 Lisp_Object Qdbus_get_unique_name;
  35 Lisp_Object Qdbus_call_method;
  36 Lisp_Object Qdbus_send_signal;
  37 Lisp_Object Qdbus_register_signal;
  38 Lisp_Object Qdbus_unregister_signal;
  39
  40 /* D-Bus error symbol.  */
  41 Lisp_Object Qdbus_error;
  42
  43 /* Lisp symbols of the system and session buses.  */
  44 Lisp_Object QCdbus_system_bus, QCdbus_session_bus;
  45
  46 /* Lisp symbols of D-Bus types.  */
  47 Lisp_Object QCdbus_type_byte, QCdbus_type_boolean;
  48 Lisp_Object QCdbus_type_int16, QCdbus_type_uint16;
  49 Lisp_Object QCdbus_type_int32, QCdbus_type_uint32;
  50 Lisp_Object QCdbus_type_int64, QCdbus_type_uint64;
  51 Lisp_Object QCdbus_type_double, QCdbus_type_string;
  52 Lisp_Object QCdbus_type_object_path, QCdbus_type_signature;
  53 Lisp_Object QCdbus_type_array, QCdbus_type_variant;
  54 Lisp_Object QCdbus_type_struct, QCdbus_type_dict_entry;
  55
  56 /* Hash table which keeps function definitions.  */
  57 Lisp_Object Vdbus_registered_functions_table;
  58
  59 /* Whether to debug D-Bus.  */
  60 Lisp_Object Vdbus_debug;
  61
  62 \f
  63 /* We use "xd_" and "XD_" as prefix for all internal symbols, because
  64    we don't want to poison other namespaces with "dbus_".  */
  65
  66 /* Raise a Lisp error from a D-Bus ERROR.  */
  67 #define XD_ERROR(error)                                                 \
  68   {                                                                     \
  69     char s[1024];                                                       \
  70     strcpy (s, error.message);                                          \
  71     dbus_error_free (&error);                                           \
  72     /* Remove the trailing newline.  */                                 \
  73     if (strchr (s, '\n') != NULL)                                       \
  74       s[strlen (s) - 1] = '\0';                                         \
  75     xsignal1 (Qdbus_error, build_string (s));                           \
  76   }
  77
  78 /* Macros for debugging.  In order to enable them, build with
  79    "make MYCPPFLAGS='-DDBUS_DEBUG'".  */
  80 #ifdef DBUS_DEBUG
  81 #define XD_DEBUG_MESSAGE(...)           \
  82   {                                     \
  83     char s[1024];                       \
  84     sprintf (s, __VA_ARGS__);           \
  85     printf ("%s: %s\n", __func__, s);   \
  86     message ("%s: %s", __func__, s);    \
  87   }
  88 #define XD_DEBUG_VALID_LISP_OBJECT_P(object)                            \
  89   if (!valid_lisp_object_p (object))                                    \
  90     {                                                                   \
  91       XD_DEBUG_MESSAGE ("%s Assertion failure", __LINE__);              \
  92       xsignal1 (Qdbus_error, build_string ("Assertion failure"));       \
  93     }
  94
  95 #else /* !DBUS_DEBUG */
  96 #define XD_DEBUG_MESSAGE(...)           \
  97   if (!NILP (Vdbus_debug))              \
  98     {                                   \
  99       char s[1024];                     \
 100       sprintf (s, __VA_ARGS__);         \
 101       message ("%s: %s", __func__, s);  \
 102     }
 103 #define XD_DEBUG_VALID_LISP_OBJECT_P(object)
 104 #endif
 105
 106 /* Check whether TYPE is a basic DBusType.  */
 107 #define XD_BASIC_DBUS_TYPE(type)                                        \
 108   ((type ==  DBUS_TYPE_BYTE)                                            \
 109    || (type ==  DBUS_TYPE_BOOLEAN)                                      \
 110    || (type ==  DBUS_TYPE_INT16)                                        \
 111    || (type ==  DBUS_TYPE_UINT16)                                       \
 112    || (type ==  DBUS_TYPE_INT32)                                        \
 113    || (type ==  DBUS_TYPE_UINT32)                                       \
 114    || (type ==  DBUS_TYPE_INT64)                                        \
 115    || (type ==  DBUS_TYPE_UINT64)                                       \
 116    || (type ==  DBUS_TYPE_DOUBLE)                                       \
 117    || (type ==  DBUS_TYPE_STRING)                                       \
 118    || (type ==  DBUS_TYPE_OBJECT_PATH)                                  \
 119    || (type ==  DBUS_TYPE_SIGNATURE))
 120
 121 /* Determine the DBusType of a given Lisp symbol.  OBJECT must be one
 122    of the predefined D-Bus type symbols.  */
 123 #define XD_SYMBOL_TO_DBUS_TYPE(object)                                  \
 124   ((EQ (object, QCdbus_type_byte)) ? DBUS_TYPE_BYTE                     \
 125    : (EQ (object, QCdbus_type_boolean)) ? DBUS_TYPE_BOOLEAN             \
 126    : (EQ (object, QCdbus_type_int16)) ? DBUS_TYPE_INT16                 \
 127    : (EQ (object, QCdbus_type_uint16)) ? DBUS_TYPE_UINT16               \
 128    : (EQ (object, QCdbus_type_int32)) ? DBUS_TYPE_INT32                 \
 129    : (EQ (object, QCdbus_type_uint32)) ? DBUS_TYPE_UINT32               \
 130    : (EQ (object, QCdbus_type_int64)) ? DBUS_TYPE_INT64                 \
 131    : (EQ (object, QCdbus_type_uint64)) ? DBUS_TYPE_UINT64               \
 132    : (EQ (object, QCdbus_type_double)) ? DBUS_TYPE_DOUBLE               \
 133    : (EQ (object, QCdbus_type_string)) ? DBUS_TYPE_STRING               \
 134    : (EQ (object, QCdbus_type_object_path)) ? DBUS_TYPE_OBJECT_PATH     \
 135    : (EQ (object, QCdbus_type_signature)) ? DBUS_TYPE_SIGNATURE         \
 136    : (EQ (object, QCdbus_type_array)) ? DBUS_TYPE_ARRAY                 \
 137    : (EQ (object, QCdbus_type_variant)) ? DBUS_TYPE_VARIANT             \
 138    : (EQ (object, QCdbus_type_struct)) ? DBUS_TYPE_STRUCT               \
 139    : (EQ (object, QCdbus_type_dict_entry)) ? DBUS_TYPE_DICT_ENTRY       \
 140    : DBUS_TYPE_INVALID)
 141
 142 /* Check whether a Lisp symbol is a predefined D-Bus type symbol.  */
 143 #define XD_DBUS_TYPE_P(object)                                          \
 144   (SYMBOLP (object) && ((XD_SYMBOL_TO_DBUS_TYPE (object) != DBUS_TYPE_INVALID)))
 145
 146 /* Determine the DBusType of a given Lisp OBJECT.  It is used to
 147    convert Lisp objects, being arguments of `dbus-call-method' or
 148    `dbus-send-signal', into corresponding C values appended as
 149    arguments to a D-Bus message.  */
 150 #define XD_OBJECT_TO_DBUS_TYPE(object)                                  \
 151   ((EQ (object, Qt) || EQ (object, Qnil)) ? DBUS_TYPE_BOOLEAN           \
 152    : (NATNUMP (object)) ? DBUS_TYPE_UINT32                              \
 153    : (INTEGERP (object)) ? DBUS_TYPE_INT32                              \
 154    : (FLOATP (object)) ? DBUS_TYPE_DOUBLE                               \
 155    : (STRINGP (object)) ? DBUS_TYPE_STRING                              \
 156    : (XD_DBUS_TYPE_P (object)) ? XD_SYMBOL_TO_DBUS_TYPE (object)        \
 157    : (CONSP (object)) ? ((XD_DBUS_TYPE_P (XCAR (object)))               \
 158                          ? XD_SYMBOL_TO_DBUS_TYPE (XCAR (object))       \
 159                          : DBUS_TYPE_ARRAY)                             \
 160    : DBUS_TYPE_INVALID)
 161
 162 /* Return a list pointer which does not have a Lisp symbol as car.  */
 163 #define XD_NEXT_VALUE(object)                                   \
 164   ((XD_DBUS_TYPE_P (XCAR (object))) ? XCDR (object) : object)
 165
 166 /* Compute SIGNATURE of OBJECT.  It must have a form that it can be
 167    used in dbus_message_iter_open_container.  DTYPE is the DBusType
 168    the object is related to.  It is passed as argument, because it
 169    cannot be detected in basic type objects, when they are preceded by
 170    a type symbol.  PARENT_TYPE is the DBusType of a container this
 171    signature is embedded, or DBUS_TYPE_INVALID.  It is needed for the
 172    check that DBUS_TYPE_DICT_ENTRY occurs only as array element.  */
 173 void
 174 xd_signature(signature, dtype, parent_type, object)
 175      char *signature;
 176      unsigned int dtype, parent_type;
 177      Lisp_Object object;
 178 {
 179   unsigned int subtype;
 180   Lisp_Object elt;
 181   char x[DBUS_MAXIMUM_SIGNATURE_LENGTH];
 182
 183   elt = object;
 184
 185   switch (dtype)
 186     {
 187     case DBUS_TYPE_BYTE:
 188     case DBUS_TYPE_UINT16:
 189     case DBUS_TYPE_UINT32:
 190     case DBUS_TYPE_UINT64:
 191       CHECK_NATNUM (object);
 192       sprintf (signature, "%c", dtype);
 193       break;
 194
 195     case DBUS_TYPE_BOOLEAN:
 196       if (!EQ (object, Qt) && !EQ (object, Qnil))
 197         wrong_type_argument (intern ("booleanp"), object);
 198       sprintf (signature, "%c", dtype);
 199       break;
 200
 201     case DBUS_TYPE_INT16:
 202     case DBUS_TYPE_INT32:
 203     case DBUS_TYPE_INT64:
 204       CHECK_NUMBER (object);
 205       sprintf (signature, "%c", dtype);
 206       break;
 207
 208     case DBUS_TYPE_DOUBLE:
 209       CHECK_FLOAT (object);
 210       sprintf (signature, "%c", dtype);
 211       break;
 212
 213     case DBUS_TYPE_STRING:
 214     case DBUS_TYPE_OBJECT_PATH:
 215     case DBUS_TYPE_SIGNATURE:
 216       CHECK_STRING (object);
 217       sprintf (signature, "%c", dtype);
 218       break;
 219
 220     case DBUS_TYPE_ARRAY:
 221       /* Check that all list elements have the same D-Bus type.  For
 222          complex element types, we just check the container type, not
 223          the whole element's signature.  */
 224       CHECK_CONS (object);
 225
 226       if (EQ (QCdbus_type_array, XCAR (elt))) /* Type symbol is optional.  */
 227         elt = XD_NEXT_VALUE (elt);
 228       subtype = XD_OBJECT_TO_DBUS_TYPE (XCAR (elt));
 229       xd_signature (x, subtype, dtype, XCAR (XD_NEXT_VALUE (elt)));
 230
 231       while (!NILP (elt))
 232         {
 233           if (subtype != XD_OBJECT_TO_DBUS_TYPE (XCAR (elt)))
 234             wrong_type_argument (intern ("D-Bus"), XCAR (elt));
 235           elt = XCDR (XD_NEXT_VALUE (elt));
 236         }
 237
 238       sprintf (signature, "%c%s", dtype, x);
 239       break;
 240
 241     case DBUS_TYPE_VARIANT:
 242       /* Check that there is exactly one list element.  */
 243       CHECK_CONS (object);
 244
 245       elt = XD_NEXT_VALUE (elt);
 246       subtype = XD_OBJECT_TO_DBUS_TYPE (XCAR (elt));
 247       xd_signature (x, subtype, dtype, XCAR (XD_NEXT_VALUE (elt)));
 248
 249       if (!NILP (XCDR (XD_NEXT_VALUE (elt))))
 250         wrong_type_argument (intern ("D-Bus"),
 251                              XCAR (XCDR (XD_NEXT_VALUE (elt))));
 252
 253       sprintf (signature, "%c%s", dtype, x);
 254       break;
 255
 256     case DBUS_TYPE_STRUCT:
 257       /* A struct list might contain any number of elements with
 258          different types.  No further check needed.  */
 259       CHECK_CONS (object);
 260
 261       elt = XD_NEXT_VALUE (elt);
 262
 263       /* Compose the signature from the elements.  It is enclosed by
 264          parentheses.  */
 265       sprintf (signature, "%c", DBUS_STRUCT_BEGIN_CHAR );
 266       while (!NILP (elt))
 267         {
 268           subtype = XD_OBJECT_TO_DBUS_TYPE (XCAR (elt));
 269           xd_signature (x, subtype, dtype, XCAR (XD_NEXT_VALUE (elt)));
 270           strcat (signature, x);
 271           elt = XCDR (XD_NEXT_VALUE (elt));
 272         }
 273       sprintf (signature, "%s%c", signature, DBUS_STRUCT_END_CHAR);
 274       break;
 275
 276     case DBUS_TYPE_DICT_ENTRY:
 277       /* Check that there are exactly two list elements, and the first
 278          one is of basic type.  The dictionary entry itself must be an
 279          element of an array.  */
 280       CHECK_CONS (object);
 281
 282       /* Check the parent object type.  */
 283       if (parent_type != DBUS_TYPE_ARRAY)
 284         wrong_type_argument (intern ("D-Bus"), object);
 285
 286       /* Compose the signature from the elements.  It is enclosed by
 287          curly braces.  */
 288       sprintf (signature, "%c", DBUS_DICT_ENTRY_BEGIN_CHAR);
 289
 290       /* First element.  */
 291       elt = XD_NEXT_VALUE (elt);
 292       subtype = XD_OBJECT_TO_DBUS_TYPE (XCAR (elt));
 293       xd_signature (x, subtype, dtype, XCAR (XD_NEXT_VALUE (elt)));
 294       strcat (signature, x);
 295
 296       if (!XD_BASIC_DBUS_TYPE (subtype))
 297         wrong_type_argument (intern ("D-Bus"), XCAR (XD_NEXT_VALUE (elt)));
 298
 299       /* Second element.  */
 300       elt = XCDR (XD_NEXT_VALUE (elt));
 301       subtype = XD_OBJECT_TO_DBUS_TYPE (XCAR (elt));
 302       xd_signature (x, subtype, dtype, XCAR (XD_NEXT_VALUE (elt)));
 303       strcat (signature, x);
 304
 305       if (!NILP (XCDR (XD_NEXT_VALUE (elt))))
 306         wrong_type_argument (intern ("D-Bus"),
 307                              XCAR (XCDR (XD_NEXT_VALUE (elt))));
 308
 309       /* Closing signature.  */
 310       sprintf (signature, "%s%c", signature, DBUS_DICT_ENTRY_END_CHAR);
 311       break;
 312
 313     default:
 314       wrong_type_argument (intern ("D-Bus"), object);
 315     }
 316
 317   XD_DEBUG_MESSAGE ("%s", signature);
 318 }
 319
 320 /* Append C value, extracted from Lisp OBJECT, to iteration ITER.
 321    DTYPE must be a valid DBusType.  It is used to convert Lisp
 322    objects, being arguments of `dbus-call-method' or
 323    `dbus-send-signal', into corresponding C values appended as
 324    arguments to a D-Bus message.  */
 325 void
 326 xd_append_arg (dtype, object, iter)
 327      unsigned int dtype;
 328      Lisp_Object object;
 329      DBusMessageIter *iter;
 330 {
 331   Lisp_Object elt;
 332   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
 333   DBusMessageIter subiter;
 334   char *value;
 335
 336   XD_DEBUG_MESSAGE ("%c %s", dtype, SDATA (format2 ("%s", object, Qnil)));
 337
 338   if (XD_BASIC_DBUS_TYPE (dtype))
 339     {
 340       switch (dtype)
 341         {
 342         case DBUS_TYPE_BYTE:
 343           XD_DEBUG_MESSAGE ("%c %u", dtype, XUINT (object));
 344           value = (unsigned char *) XUINT (object);
 345           break;
 346
 347         case DBUS_TYPE_BOOLEAN:
 348           XD_DEBUG_MESSAGE ("%c %s", dtype, (NILP (object)) ? "false" : "true");
 349           value = (NILP (object))
 350             ? (unsigned char *) FALSE : (unsigned char *) TRUE;
 351           break;
 352
 353         case DBUS_TYPE_INT16:
 354           XD_DEBUG_MESSAGE ("%c %d", dtype, XINT (object));
 355           value = (char *) (dbus_int16_t *) XINT (object);
 356           break;
 357
 358         case DBUS_TYPE_UINT16:
 359           XD_DEBUG_MESSAGE ("%c %u", dtype, XUINT (object));
 360           value = (char *) (dbus_uint16_t *) XUINT (object);
 361           break;
 362
 363         case DBUS_TYPE_INT32:
 364           XD_DEBUG_MESSAGE ("%c %d", dtype, XINT (object));
 365           value = (char *) (dbus_int32_t *) XINT (object);
 366           break;
 367
 368         case DBUS_TYPE_UINT32:
 369           XD_DEBUG_MESSAGE ("%c %u", dtype, XUINT (object));
 370           value = (char *) (dbus_uint32_t *) XUINT (object);
 371           break;
 372
 373         case DBUS_TYPE_INT64:
 374           XD_DEBUG_MESSAGE ("%c %d", dtype, XINT (object));
 375           value = (char *) (dbus_int64_t *) XINT (object);
 376           break;
 377
 378         case DBUS_TYPE_UINT64:
 379           XD_DEBUG_MESSAGE ("%c %u", dtype, XUINT (object));
 380           value = (char *) (dbus_int64_t *) XUINT (object);
 381           break;
 382
 383         case DBUS_TYPE_DOUBLE:
 384           XD_DEBUG_MESSAGE ("%c %f", dtype, XFLOAT (object));
 385           value = (char *) (float *) XFLOAT (object);
 386           break;
 387
 388         case DBUS_TYPE_STRING:
 389         case DBUS_TYPE_OBJECT_PATH:
 390         case DBUS_TYPE_SIGNATURE:
 391           XD_DEBUG_MESSAGE ("%c %s", dtype, SDATA (object));
 392           value = SDATA (object);
 393           break;
 394         }
 395
 396       if (!dbus_message_iter_append_basic (iter, dtype, &value))
 397         xsignal2 (Qdbus_error,
 398                   build_string ("Unable to append argument"), object);
 399     }
 400
 401   else /* Compound types.  */
 402     {
 403
 404       /* All compound types except array have a type symbol.  For
 405          array, it is optional.  Skip it.  */
 406       if (!XD_BASIC_DBUS_TYPE (XD_OBJECT_TO_DBUS_TYPE (XCAR (object))))
 407         object = XD_NEXT_VALUE (object);
 408
 409       /* Open new subiteration.  */
 410       switch (dtype)
 411         {
 412         case DBUS_TYPE_ARRAY:
 413         case DBUS_TYPE_VARIANT:
 414           /* A variant has just one element.  An array has elements of
 415              the same type.  Both have been checked already for
 416              correct types, it is sufficient to retrieve just the
 417              signature of the first element.  */
 418           xd_signature (signature, XD_OBJECT_TO_DBUS_TYPE (XCAR (object)),
 419                         dtype, XCAR (XD_NEXT_VALUE (object)));
 420           XD_DEBUG_MESSAGE ("%c %s %s", dtype, signature,
 421                             SDATA (format2 ("%s", object, Qnil)));
 422           if (!dbus_message_iter_open_container (iter, dtype,
 423                                                  signature, &subiter))
 424             xsignal3 (Qdbus_error,
 425                       build_string ("Cannot open container"),
 426                       make_number (dtype), build_string (signature));
 427           break;
 428
 429         case DBUS_TYPE_STRUCT:
 430         case DBUS_TYPE_DICT_ENTRY:
 431           /* These containers do not require a signature.  */
 432           XD_DEBUG_MESSAGE ("%c %s", dtype,
 433                             SDATA (format2 ("%s", object, Qnil)));
 434           if (!dbus_message_iter_open_container (iter, dtype, NULL, &subiter))
 435             xsignal2 (Qdbus_error,
 436                       build_string ("Cannot open container"),
 437                       make_number (dtype));
 438           break;
 439         }
 440
 441       /* Loop over list elements.  */
 442       while (!NILP (object))
 443         {
 444           dtype = XD_OBJECT_TO_DBUS_TYPE (XCAR (object));
 445           object = XD_NEXT_VALUE (object);
 446
 447           xd_append_arg (dtype, XCAR (object), &subiter);
 448
 449           object = XCDR (object);
 450         }
 451
 452       /* Close the subiteration.  */
 453       if (!dbus_message_iter_close_container (iter, &subiter))
 454         xsignal2 (Qdbus_error,
 455                   build_string ("Cannot close container"),
 456                   make_number (dtype));
 457     }
 458 }
 459
 460 /* Retrieve C value from a DBusMessageIter structure ITER, and return
 461    a converted Lisp object.  The type DTYPE of the argument of the
 462    D-Bus message must be a valid DBusType.  Compound D-Bus types
 463    result always in a Lisp list.  */
 464 Lisp_Object
 465 xd_retrieve_arg (dtype, iter)
 466      unsigned int dtype;
 467      DBusMessageIter *iter;
 468 {
 469
 470   switch (dtype)
 471     {
 472     case DBUS_TYPE_BYTE:
 473     case DBUS_TYPE_INT16:
 474     case DBUS_TYPE_UINT16:
 475       {
 476         dbus_uint16_t val;
 477         dbus_message_iter_get_basic (iter, &val);
 478         XD_DEBUG_MESSAGE ("%c %d", dtype, val);
 479         return make_number (val);
 480       }
 481
 482     case DBUS_TYPE_BOOLEAN:
 483       {
 484         dbus_bool_t val;
 485         dbus_message_iter_get_basic (iter, &val);
 486         XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true");
 487         return (val == FALSE) ? Qnil : Qt;
 488       }
 489
 490     case DBUS_TYPE_INT32:
 491     case DBUS_TYPE_UINT32:
 492       {
 493         dbus_uint32_t val;
 494         dbus_message_iter_get_basic (iter, &val);
 495         if (FIXNUM_OVERFLOW_P (val))
 496           XD_DEBUG_MESSAGE ("%c %f", dtype, val)
 497         else
 498           XD_DEBUG_MESSAGE ("%c %d", dtype, val);
 499         return make_fixnum_or_float (val);
 500       }
 501
 502     case DBUS_TYPE_INT64:
 503     case DBUS_TYPE_UINT64:
 504       {
 505         dbus_uint64_t val;
 506         dbus_message_iter_get_basic (iter, &val);
 507         if (FIXNUM_OVERFLOW_P (val))
 508           XD_DEBUG_MESSAGE ("%c %f", dtype, val)
 509         else
 510           XD_DEBUG_MESSAGE ("%c %d", dtype, val);
 511         return make_fixnum_or_float (val);
 512       }
 513
 514     case DBUS_TYPE_DOUBLE:
 515       {
 516         double val;
 517         dbus_message_iter_get_basic (iter, &val);
 518         XD_DEBUG_MESSAGE ("%c %f", dtype, val);
 519         return make_float (val);
 520       }
 521
 522     case DBUS_TYPE_STRING:
 523     case DBUS_TYPE_OBJECT_PATH:
 524     case DBUS_TYPE_SIGNATURE:
 525       {
 526         char *val;
 527         dbus_message_iter_get_basic (iter, &val);
 528         XD_DEBUG_MESSAGE ("%c %s", dtype, val);
 529         return build_string (val);
 530       }
 531
 532     case DBUS_TYPE_ARRAY:
 533     case DBUS_TYPE_VARIANT:
 534     case DBUS_TYPE_STRUCT:
 535     case DBUS_TYPE_DICT_ENTRY:
 536       {
 537         Lisp_Object result;
 538         struct gcpro gcpro1;
 539         result = Qnil;
 540         GCPRO1 (result);
 541         DBusMessageIter subiter;
 542         int subtype;
 543         dbus_message_iter_recurse (iter, &subiter);
 544         while ((subtype = dbus_message_iter_get_arg_type (&subiter))
 545                != DBUS_TYPE_INVALID)
 546           {
 547             result = Fcons (xd_retrieve_arg (subtype, &subiter), result);
 548             dbus_message_iter_next (&subiter);
 549           }
 550         RETURN_UNGCPRO (Fnreverse (result));
 551       }
 552
 553     default:
 554       XD_DEBUG_MESSAGE ("DBusType '%c' not supported", dtype);
 555       return Qnil;
 556     }
 557 }
 558
 559
 560 /* Initialize D-Bus connection.  BUS is a Lisp symbol, either :system
 561    or :session.  It tells which D-Bus to be initialized.  */
 562 DBusConnection *
 563 xd_initialize (bus)
 564      Lisp_Object bus;
 565 {
 566   DBusConnection *connection;
 567   DBusError derror;
 568
 569   /* Parameter check.  */
 570   CHECK_SYMBOL (bus);
 571   if (!((EQ (bus, QCdbus_system_bus)) || (EQ (bus, QCdbus_session_bus))))
 572     xsignal2 (Qdbus_error, build_string ("Wrong bus name"), bus);
 573
 574   /* Open a connection to the bus.  */
 575   dbus_error_init (&derror);
 576
 577   if (EQ (bus, QCdbus_system_bus))
 578     connection = dbus_bus_get (DBUS_BUS_SYSTEM, &derror);
 579   else
 580     connection = dbus_bus_get (DBUS_BUS_SESSION, &derror);
 581
 582   if (dbus_error_is_set (&derror))
 583     XD_ERROR (derror);
 584
 585   if (connection == NULL)
 586     xsignal2 (Qdbus_error, build_string ("No connection"), bus);
 587
 588   /* Return the result.  */
 589   return connection;
 590 }
 591
 592 DEFUN ("dbus-get-unique-name", Fdbus_get_unique_name, Sdbus_get_unique_name,
 593        1, 1, 0,
 594        doc: /* Return the unique name of Emacs registered at D-Bus BUS as string.  */)
 595      (bus)
 596      Lisp_Object bus;
 597 {
 598   DBusConnection *connection;
 599   char name[DBUS_MAXIMUM_NAME_LENGTH];
 600
 601   /* Check parameters.  */
 602   CHECK_SYMBOL (bus);
 603
 604   /* Open a connection to the bus.  */
 605   connection = xd_initialize (bus);
 606
 607   /* Request the name.  */
 608   strcpy (name, dbus_bus_get_unique_name (connection));
 609   if (name == NULL)
 610     xsignal1 (Qdbus_error, build_string ("No unique name available"));
 611
 612   /* Return.  */
 613   return build_string (name);
 614 }
 615
 616 DEFUN ("dbus-call-method", Fdbus_call_method, Sdbus_call_method, 5, MANY, 0,
 617        doc: /* Call METHOD on the D-Bus BUS.
 618
 619 BUS is either the symbol `:system' or the symbol `:session'.
 620
 621 SERVICE is the D-Bus service name to be used.  PATH is the D-Bus
 622 object path SERVICE is registered at.  INTERFACE is an interface
 623 offered by SERVICE.  It must provide METHOD.
 624
 625 All other arguments ARGS are passed to METHOD as arguments.  They are
 626 converted into D-Bus types via the following rules:
 627
 628   t and nil => DBUS_TYPE_BOOLEAN
 629   number    => DBUS_TYPE_UINT32
 630   integer   => DBUS_TYPE_INT32
 631   float     => DBUS_TYPE_DOUBLE
 632   string    => DBUS_TYPE_STRING
 633   list      => DBUS_TYPE_ARRAY
 634
 635 All arguments can be preceded by a type symbol.  For details about
 636 type symbols, see Info node `(dbus)Type Conversion'.
 637
 638 `dbus-call-method' returns the resulting values of METHOD as a list of
 639 Lisp objects.  The type conversion happens the other direction as for
 640 input arguments.  It follows the mapping rules:
 641
 642   DBUS_TYPE_BOOLEAN     => t or nil
 643   DBUS_TYPE_BYTE        => number
 644   DBUS_TYPE_UINT16      => number
 645   DBUS_TYPE_INT16       => integer
 646   DBUS_TYPE_UINT32      => number or float
 647   DBUS_TYPE_INT32       => integer or float
 648   DBUS_TYPE_UINT64      => number or float
 649   DBUS_TYPE_INT64       => integer or float
 650   DBUS_TYPE_DOUBLE      => float
 651   DBUS_TYPE_STRING      => string
 652   DBUS_TYPE_OBJECT_PATH => string
 653   DBUS_TYPE_SIGNATURE   => string
 654   DBUS_TYPE_ARRAY       => list
 655   DBUS_TYPE_VARIANT     => list
 656   DBUS_TYPE_STRUCT      => list
 657   DBUS_TYPE_DICT_ENTRY  => list
 658
 659 Example:
 660
 661 \(dbus-call-method
 662   :session "org.gnome.seahorse" "/org/gnome/seahorse/keys/openpgp"
 663   "org.gnome.seahorse.Keys" "GetKeyField"
 664   "openpgp:657984B8C7A966DD" "simple-name")
 665
 666   => (t ("Philip R. Zimmermann"))
 667
 668 If the result of the METHOD call is just one value, the converted Lisp
 669 object is returned instead of a list containing this single Lisp object.
 670
 671 \(dbus-call-method
 672   :system "org.freedesktop.Hal" "/org/freedesktop/Hal/devices/computer"
 673   "org.freedesktop.Hal.Device" "GetPropertyString"
 674   "system.kernel.machine")
 675
 676   => "i686"
 677
 678 usage: (dbus-call-method BUS SERVICE PATH INTERFACE METHOD &rest ARGS)  */)
 679      (nargs, args)
 680      int nargs;
 681      register Lisp_Object *args;
 682 {
 683   Lisp_Object bus, service, path, interface, method;
 684   Lisp_Object result;
 685   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
 686   DBusConnection *connection;
 687   DBusMessage *dmessage;
 688   DBusMessage *reply;
 689   DBusMessageIter iter;
 690   DBusError derror;
 691   unsigned int dtype;
 692   int i;
 693   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
 694
 695   /* Check parameters.  */
 696   bus = args[0];
 697   service = args[1];
 698   path = args[2];
 699   interface = args[3];
 700   method = args[4];
 701
 702   CHECK_SYMBOL (bus);
 703   CHECK_STRING (service);
 704   CHECK_STRING (path);
 705   CHECK_STRING (interface);
 706   CHECK_STRING (method);
 707   GCPRO5 (bus, service, path, interface, method);
 708
 709   XD_DEBUG_MESSAGE ("%s %s %s %s",
 710                     SDATA (service),
 711                     SDATA (path),
 712                     SDATA (interface),
 713                     SDATA (method));
 714
 715   /* Open a connection to the bus.  */
 716   connection = xd_initialize (bus);
 717
 718   /* Create the message.  */
 719   dmessage = dbus_message_new_method_call ((char *) SDATA (service),
 720                                            (char *) SDATA (path),
 721                                            (char *) SDATA (interface),
 722                                            (char *) SDATA (method));
 723   if (dmessage == NULL)
 724     {
 725       UNGCPRO;
 726       xsignal1 (Qdbus_error, build_string ("Unable to create a new message"));
 727     }
 728
 729   UNGCPRO;
 730
 731   /* Initialize parameter list of message.  */
 732   dbus_message_iter_init_append (dmessage, &iter);
 733
 734   /* Append parameters to the message.  */
 735   for (i = 5; i < nargs; ++i)
 736     {
 737
 738       XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
 739       XD_DEBUG_MESSAGE ("Parameter%d %s",
 740                         i-4, SDATA (format2 ("%s", args[i], Qnil)));
 741
 742       dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
 743       if (XD_DBUS_TYPE_P (args[i]))
 744         ++i;
 745
 746       /* Check for valid signature.  We use DBUS_TYPE_INVALID is
 747          indication that there is no parent type.  */
 748       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
 749
 750       xd_append_arg (dtype, args[i], &iter);
 751     }
 752
 753   /* Send the message.  */
 754   dbus_error_init (&derror);
 755   reply = dbus_connection_send_with_reply_and_block (connection,
 756                                                      dmessage,
 757                                                      -1,
 758                                                      &derror);
 759
 760   if (dbus_error_is_set (&derror))
 761     XD_ERROR (derror);
 762
 763   if (reply == NULL)
 764     xsignal1 (Qdbus_error, build_string ("No reply"));
 765
 766   XD_DEBUG_MESSAGE ("Message sent");
 767
 768   /* Collect the results.  */
 769   result = Qnil;
 770   GCPRO1 (result);
 771
 772   if (!dbus_message_iter_init (reply, &iter))
 773     {
 774       UNGCPRO;
 775       xsignal1 (Qdbus_error, build_string ("Cannot read reply"));
 776     }
 777
 778   /* Loop over the parameters of the D-Bus reply message.  Construct a
 779      Lisp list, which is returned by `dbus-call-method'.  */
 780   while ((dtype = dbus_message_iter_get_arg_type (&iter)) != DBUS_TYPE_INVALID)
 781     {
 782       result = Fcons (xd_retrieve_arg (dtype, &iter), result);
 783       dbus_message_iter_next (&iter);
 784     }
 785
 786   /* Cleanup.  */
 787   dbus_message_unref (dmessage);
 788   dbus_message_unref (reply);
 789
 790   /* Return the result.  If there is only one single Lisp object,
 791      return it as-it-is, otherwise return the reversed list.  */
 792   if (XUINT (Flength (result)) == 1)
 793     RETURN_UNGCPRO (XCAR (result));
 794   else
 795     RETURN_UNGCPRO (Fnreverse (result));
 796 }
 797
 798 DEFUN ("dbus-send-signal", Fdbus_send_signal, Sdbus_send_signal, 5, MANY, 0,
 799        doc: /* Send signal SIGNAL on the D-Bus BUS.
 800
 801 BUS is either the symbol `:system' or the symbol `:session'.
 802
 803 SERVICE is the D-Bus service name SIGNAL is sent from.  PATH is the
 804 D-Bus object path SERVICE is registered at.  INTERFACE is an interface
 805 offered by SERVICE.  It must provide signal SIGNAL.
 806
 807 All other arguments ARGS are passed to SIGNAL as arguments.  They are
 808 converted into D-Bus types via the following rules:
 809
 810   t and nil => DBUS_TYPE_BOOLEAN
 811   number    => DBUS_TYPE_UINT32
 812   integer   => DBUS_TYPE_INT32
 813   float     => DBUS_TYPE_DOUBLE
 814   string    => DBUS_TYPE_STRING
 815   list      => DBUS_TYPE_ARRAY
 816
 817 All arguments can be preceded by a type symbol.  For details about
 818 type symbols, see Info node `(dbus)Type Conversion'.
 819
 820 Example:
 821
 822 \(dbus-send-signal
 823   :session "org.gnu.Emacs" "/org/gnu/Emacs"
 824   "org.gnu.Emacs.FileManager" "FileModified" "/home/albinus/.emacs")
 825
 826 usage: (dbus-send-signal BUS SERVICE PATH INTERFACE SIGNAL &rest ARGS)  */)
 827      (nargs, args)
 828      int nargs;
 829      register Lisp_Object *args;
 830 {
 831   Lisp_Object bus, service, path, interface, signal;
 832   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
 833   DBusConnection *connection;
 834   DBusMessage *dmessage;
 835   DBusMessageIter iter;
 836   unsigned int dtype;
 837   int i;
 838   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
 839
 840   /* Check parameters.  */
 841   bus = args[0];
 842   service = args[1];
 843   path = args[2];
 844   interface = args[3];
 845   signal = args[4];
 846
 847   CHECK_SYMBOL (bus);
 848   CHECK_STRING (service);
 849   CHECK_STRING (path);
 850   CHECK_STRING (interface);
 851   CHECK_STRING (signal);
 852   GCPRO5 (bus, service, path, interface, signal);
 853
 854   XD_DEBUG_MESSAGE ("%s %s %s %s",
 855                     SDATA (service),
 856                     SDATA (path),
 857                     SDATA (interface),
 858                     SDATA (signal));
 859
 860   /* Open a connection to the bus.  */
 861   connection = xd_initialize (bus);
 862
 863   /* Create the message.  */
 864   dmessage = dbus_message_new_signal ((char *) SDATA (path),
 865                                       (char *) SDATA (interface),
 866                                       (char *) SDATA (signal));
 867   if (dmessage == NULL)
 868     {
 869       UNGCPRO;
 870       xsignal1 (Qdbus_error, build_string ("Unable to create a new message"));
 871     }
 872
 873   UNGCPRO;
 874
 875   /* Initialize parameter list of message.  */
 876   dbus_message_iter_init_append (dmessage, &iter);
 877
 878   /* Append parameters to the message.  */
 879   for (i = 5; i < nargs; ++i)
 880     {
 881       XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
 882       XD_DEBUG_MESSAGE ("Parameter%d %s",
 883                         i-4, SDATA (format2 ("%s", args[i], Qnil)));
 884
 885       dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
 886       if (XD_DBUS_TYPE_P (args[i]))
 887         ++i;
 888
 889       /* Check for valid signature.  We use DBUS_TYPE_INVALID is
 890          indication that there is no parent type.  */
 891       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
 892
 893       xd_append_arg (dtype, args[i], &iter);
 894     }
 895
 896   /* Send the message.  The message is just added to the outgoing
 897      message queue.  */
 898   if (!dbus_connection_send (connection, dmessage, NULL))
 899     xsignal1 (Qdbus_error, build_string ("Cannot send message"));
 900
 901   /* Flush connection to ensure the message is handled.  */
 902   dbus_connection_flush (connection);
 903
 904   XD_DEBUG_MESSAGE ("Signal sent");
 905
 906   /* Cleanup.  */
 907   dbus_message_unref (dmessage);
 908
 909   /* Return.  */
 910   return Qt;
 911 }
 912
 913 /* Read queued incoming message of the D-Bus BUS.  BUS is a Lisp
 914    symbol, either :system or :session.  */
 915 Lisp_Object
 916 xd_read_message (bus)
 917      Lisp_Object bus;
 918 {
 919   Lisp_Object args, key, value;
 920   struct gcpro gcpro1;
 921   static struct input_event event;
 922   DBusConnection *connection;
 923   DBusMessage *dmessage;
 924   DBusMessageIter iter;
 925   unsigned int dtype;
 926   char uname[DBUS_MAXIMUM_NAME_LENGTH];
 927   char path[DBUS_MAXIMUM_MATCH_RULE_LENGTH]; /* Unlimited in D-Bus spec.  */
 928   char interface[DBUS_MAXIMUM_NAME_LENGTH];
 929   char member[DBUS_MAXIMUM_NAME_LENGTH];
 930
 931   /* Open a connection to the bus.  */
 932   connection = xd_initialize (bus);
 933
 934   /* Non blocking read of the next available message.  */
 935   dbus_connection_read_write (connection, 0);
 936   dmessage = dbus_connection_pop_message (connection);
 937
 938   /* Return if there is no queued message.  */
 939   if (dmessage == NULL)
 940     return;
 941
 942   XD_DEBUG_MESSAGE ("Event received");
 943
 944   /* Collect the parameters.  */
 945   args = Qnil;
 946   GCPRO1 (args);
 947
 948   if (!dbus_message_iter_init (dmessage, &iter))
 949     {
 950       UNGCPRO;
 951       XD_DEBUG_MESSAGE ("Cannot read event");
 952       return;
 953     }
 954
 955   /* Loop over the resulting parameters.  Construct a list.  */
 956   while ((dtype = dbus_message_iter_get_arg_type (&iter)) != DBUS_TYPE_INVALID)
 957     {
 958       args = Fcons (xd_retrieve_arg (dtype, &iter), args);
 959       dbus_message_iter_next (&iter);
 960     }
 961
 962   /* The arguments are stored in reverse order.  Reorder them.  */
 963   args = Fnreverse (args);
 964
 965   /* Read unique name, object path, interface and member from the
 966      message.  */
 967   strcpy (uname,     dbus_message_get_sender (dmessage));
 968   strcpy (path,      dbus_message_get_path (dmessage));
 969   strcpy (interface, dbus_message_get_interface (dmessage));
 970   strcpy (member,    dbus_message_get_member (dmessage));
 971
 972   /* Search for a registered function of the message.  */
 973   key = list3 (bus, build_string (interface), build_string (member));
 974   value = Fgethash (key, Vdbus_registered_functions_table, Qnil);
 975
 976   /* Loop over the registered functions.  Construct an event.  */
 977   while (!NILP (value))
 978     {
 979       key = XCAR (value);
 980       /* key has the structure (UNAME SERVICE PATH HANDLER).  */
 981       if (((uname == NULL)
 982            || (NILP (XCAR (key)))
 983            || (strcmp (uname, SDATA (XCAR (key))) == 0))
 984           && ((path == NULL)
 985               || (NILP (XCAR (XCDR (XCDR (key)))))
 986               || (strcmp (path, SDATA (XCAR (XCDR (XCDR (key))))) == 0))
 987           && (!NILP (XCAR (XCDR (XCDR (XCDR (key)))))))
 988         {
 989           EVENT_INIT (event);
 990           event.kind = DBUS_EVENT;
 991           event.frame_or_window = Qnil;
 992           event.arg = Fcons (XCAR (XCDR (XCDR (XCDR (key)))), args);
 993
 994           /* Add uname, path, interface and member to the event.  */
 995           event.arg = Fcons ((member == NULL ? Qnil : build_string (member)),
 996                              event.arg);
 997           event.arg = Fcons ((interface == NULL
 998                               ? Qnil : build_string (interface)),
 999                              event.arg);
1000           event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
1001                              event.arg);
1002           event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
1003                              event.arg);
1004
1005           /* Add the bus symbol to the event.  */
1006           event.arg = Fcons (bus, event.arg);
1007
1008           /* Store it into the input event queue.  */
1009           kbd_buffer_store_event (&event);
1010         }
1011      value = XCDR (value);
1012     }
1013
1014   /* Cleanup.  */
1015   dbus_message_unref (dmessage);
1016   UNGCPRO;
1017 }
1018
1019 /* Read queued incoming messages from the system and session buses.  */
1020 void
1021 xd_read_queued_messages ()
1022 {
1023
1024   /* Vdbus_registered_functions_table will be initialized as hash
1025      table in dbus.el.  When this package isn't loaded yet, it doesn't
1026      make sense to handle D-Bus messages.  Furthermore, we ignore all
1027      Lisp errors during the call.  */
1028   if (HASH_TABLE_P (Vdbus_registered_functions_table))
1029     {
1030       internal_condition_case_1 (xd_read_message, QCdbus_system_bus,
1031                                  Qerror, Fidentity);
1032       internal_condition_case_1 (xd_read_message, QCdbus_session_bus,
1033                                  Qerror, Fidentity);
1034     }
1035 }
1036
1037 DEFUN ("dbus-register-signal", Fdbus_register_signal, Sdbus_register_signal,
1038        6, 6, 0,
1039        doc: /* Register for signal SIGNAL on the D-Bus BUS.
1040
1041 BUS is either the symbol `:system' or the symbol `:session'.
1042
1043 SERVICE is the D-Bus service name used by the sending D-Bus object.
1044 It can be either a known name or the unique name of the D-Bus object
1045 sending the signal.  When SERVICE is nil, related signals from all
1046 D-Bus objects shall be accepted.
1047
1048 PATH is the D-Bus object path SERVICE is registered.  It can also be
1049 nil if the path name of incoming signals shall not be checked.
1050
1051 INTERFACE is an interface offered by SERVICE.  It must provide SIGNAL.
1052 HANDLER is a Lisp function to be called when the signal is received.
1053 It must accept as arguments the values SIGNAL is sending.  INTERFACE,
1054 SIGNAL and HANDLER must not be nil.  Example:
1055
1056 \(defun my-signal-handler (device)
1057   (message "Device %s added" device))
1058
1059 \(dbus-register-signal
1060   :system "org.freedesktop.Hal" "/org/freedesktop/Hal/Manager"
1061   "org.freedesktop.Hal.Manager" "DeviceAdded" 'my-signal-handler)
1062
1063   => ((:system "org.freedesktop.Hal.Manager" "DeviceAdded")
1064       ("org.freedesktop.Hal" "/org/freedesktop/Hal/Manager" my-signal-handler))
1065
1066 `dbus-register-signal' returns an object, which can be used in
1067 `dbus-unregister-signal' for removing the registration.  */)
1068      (bus, service, path, interface, signal, handler)
1069      Lisp_Object bus, service, path, interface, signal, handler;
1070 {
1071   Lisp_Object uname, key, value;
1072   DBusConnection *connection;
1073   char rule[DBUS_MAXIMUM_MATCH_RULE_LENGTH];
1074   DBusError derror;
1075
1076   /* Check parameters.  */
1077   CHECK_SYMBOL (bus);
1078   if (!NILP (service)) CHECK_STRING (service);
1079   if (!NILP (path)) CHECK_STRING (path);
1080   CHECK_STRING (interface);
1081   CHECK_STRING (signal);
1082   FUNCTIONP (handler);
1083
1084   /* Retrieve unique name of service.  If service is a known name, we
1085      will register for the corresponding unique name, if any.  Signals
1086      are sent always with the unique name as sender.  Note: the unique
1087      name of "org.freedesktop.DBus" is that string itself.  */
1088   if ((!NILP (service))
1089       && (strlen (SDATA (service)) > 0)
1090       && (strcmp (SDATA (service), DBUS_SERVICE_DBUS) != 0)
1091       && (strncmp (SDATA (service), ":", 1) != 0))
1092     {
1093       uname = call2 (intern ("dbus-get-name-owner"), bus, service);
1094       /* When there is no unique name, we mark it with an empty
1095          string.  */
1096       if (NILP (uname))
1097         uname = build_string ("");
1098     }
1099   else
1100     uname = service;
1101
1102   /* Create a matching rule if the unique name exists (when no
1103      wildcard).  */
1104   if (NILP (uname) || (strlen (SDATA (uname)) > 0))
1105     {
1106       /* Open a connection to the bus.  */
1107       connection = xd_initialize (bus);
1108
1109       /* Create a rule to receive related signals.  */
1110       sprintf (rule,
1111                "type='signal',interface='%s',member='%s'",
1112                SDATA (interface),
1113                SDATA (signal));
1114
1115       /* Add unique name and path to the rule if they are non-nil.  */
1116       if (!NILP (uname))
1117         sprintf (rule, "%s,sender='%s'", rule, SDATA (uname));
1118
1119       if (!NILP (path))
1120         sprintf (rule, "%s,path='%s'", rule, SDATA (path));
1121
1122       /* Add the rule to the bus.  */
1123       dbus_error_init (&derror);
1124       dbus_bus_add_match (connection, rule, &derror);
1125       if (dbus_error_is_set (&derror))
1126         XD_ERROR (derror);
1127
1128       XD_DEBUG_MESSAGE ("Matching rule \"%s\" created", rule);
1129     }
1130
1131   /* Create a hash table entry.  */
1132   key = list3 (bus, interface, signal);
1133   value = Fgethash (key, Vdbus_registered_functions_table, Qnil);
1134
1135   if (NILP (Fmember (list4 (uname, service, path, handler), value)))
1136     Fputhash (key,
1137               Fcons (list4 (uname, service, path, handler), value),
1138               Vdbus_registered_functions_table);
1139
1140   /* Return object.  */
1141   return list2 (key, list3 (service, path, handler));
1142 }
1143
1144 DEFUN ("dbus-unregister-signal", Fdbus_unregister_signal, Sdbus_unregister_signal,
1145        1, 1, 0,
1146        doc: /* Unregister OBJECT from the D-Bus.
1147 OBJECT must be the result of a preceding `dbus-register-signal' call.  */)
1148      (object)
1149      Lisp_Object object;
1150 {
1151   Lisp_Object value;
1152   struct gcpro gcpro1;
1153
1154   /* Check parameter.  */
1155   CONSP (object) && (!NILP (XCAR (object))) && CONSP (XCDR (object));
1156
1157   /* Find the corresponding entry in the hash table.  */
1158   value = Fgethash (XCAR (object), Vdbus_registered_functions_table, Qnil);
1159
1160   /* Loop over the registered functions.  */
1161   while (!NILP (value))
1162     {
1163       GCPRO1 (value);
1164
1165       /* (car value) has the structure (UNAME SERVICE PATH HANDLER).
1166          (cdr object) has the structure ((SERVICE PATH HANDLER) ...).  */
1167       if (!NILP (Fequal (XCDR (XCAR (value)), XCAR (XCDR (object)))))
1168         {
1169           /* Compute new hash value.  */
1170           value = Fdelete (XCAR (value),
1171                            Fgethash (XCAR (object),
1172                                      Vdbus_registered_functions_table, Qnil));
1173           if (NILP (value))
1174             Fremhash (XCAR (object), Vdbus_registered_functions_table);
1175           else
1176             Fputhash (XCAR (object), value, Vdbus_registered_functions_table);
1177           RETURN_UNGCPRO (Qt);
1178         }
1179       UNGCPRO;
1180       value = XCDR (value);
1181     }
1182
1183   /* Return.  */
1184   return Qnil;
1185 }
1186
1187 \f
1188 void
1189 syms_of_dbusbind ()
1190 {
1191
1192   Qdbus_get_unique_name = intern ("dbus-get-unique-name");
1193   staticpro (&Qdbus_get_unique_name);
1194   defsubr (&Sdbus_get_unique_name);
1195
1196   Qdbus_call_method = intern ("dbus-call-method");
1197   staticpro (&Qdbus_call_method);
1198   defsubr (&Sdbus_call_method);
1199
1200   Qdbus_send_signal = intern ("dbus-send-signal");
1201   staticpro (&Qdbus_send_signal);
1202   defsubr (&Sdbus_send_signal);
1203
1204   Qdbus_register_signal = intern ("dbus-register-signal");
1205   staticpro (&Qdbus_register_signal);
1206   defsubr (&Sdbus_register_signal);
1207
1208   Qdbus_unregister_signal = intern ("dbus-unregister-signal");
1209   staticpro (&Qdbus_unregister_signal);
1210   defsubr (&Sdbus_unregister_signal);
1211
1212   Qdbus_error = intern ("dbus-error");
1213   staticpro (&Qdbus_error);
1214   Fput (Qdbus_error, Qerror_conditions,
1215         list2 (Qdbus_error, Qerror));
1216   Fput (Qdbus_error, Qerror_message,
1217         build_string ("D-Bus error"));
1218
1219   QCdbus_system_bus = intern (":system");
1220   staticpro (&QCdbus_system_bus);
1221
1222   QCdbus_session_bus = intern (":session");
1223   staticpro (&QCdbus_session_bus);
1224
1225   QCdbus_type_byte = intern (":byte");
1226   staticpro (&QCdbus_type_byte);
1227
1228   QCdbus_type_boolean = intern (":boolean");
1229   staticpro (&QCdbus_type_boolean);
1230
1231   QCdbus_type_int16 = intern (":int16");
1232   staticpro (&QCdbus_type_int16);
1233
1234   QCdbus_type_uint16 = intern (":uint16");
1235   staticpro (&QCdbus_type_uint16);
1236
1237   QCdbus_type_int32 = intern (":int32");
1238   staticpro (&QCdbus_type_int32);
1239
1240   QCdbus_type_uint32 = intern (":uint32");
1241   staticpro (&QCdbus_type_uint32);
1242
1243   QCdbus_type_int64 = intern (":int64");
1244   staticpro (&QCdbus_type_int64);
1245
1246   QCdbus_type_uint64 = intern (":uint64");
1247   staticpro (&QCdbus_type_uint64);
1248
1249   QCdbus_type_double = intern (":double");
1250   staticpro (&QCdbus_type_double);
1251
1252   QCdbus_type_string = intern (":string");
1253   staticpro (&QCdbus_type_string);
1254
1255   QCdbus_type_object_path = intern (":object-path");
1256   staticpro (&QCdbus_type_object_path);
1257
1258   QCdbus_type_signature = intern (":signature");
1259   staticpro (&QCdbus_type_signature);
1260
1261   QCdbus_type_array = intern (":array");
1262   staticpro (&QCdbus_type_array);
1263
1264   QCdbus_type_variant = intern (":variant");
1265   staticpro (&QCdbus_type_variant);
1266
1267   QCdbus_type_struct = intern (":struct");
1268   staticpro (&QCdbus_type_struct);
1269
1270   QCdbus_type_dict_entry = intern (":dict-entry");
1271   staticpro (&QCdbus_type_dict_entry);
1272
1273   DEFVAR_LISP ("dbus-registered-functions-table", &Vdbus_registered_functions_table,
1274     doc: /* Hash table of registered functions for D-Bus.
1275 The key in the hash table is the list (BUS INTERFACE MEMBER).  BUS is
1276 either the symbol `:system' or the symbol `:session'.  INTERFACE is a
1277 string which denotes a D-Bus interface, and MEMBER, also a string, is
1278 either a method or a signal INTERFACE is offering.  All arguments but
1279 BUS must not be nil.
1280
1281 The value in the hash table is a list of quadruple lists
1282 \((UNAME SERVICE PATH HANDLER) (UNAME SERVICE PATH HANDLER) ...).
1283 SERVICE is the service name as registered, UNAME is the corresponding
1284 unique name.  PATH is the object path of the sending object.  All of
1285 them can be nil, which means a wildcard then.  HANDLER is the function
1286 to be called when a D-Bus message, which matches the key criteria,
1287 arrives.  */);
1288   /* We initialize Vdbus_registered_functions_table in dbus.el,
1289      because we need to define a hash table function first.  */
1290   Vdbus_registered_functions_table = Qnil;
1291
1292   DEFVAR_LISP ("dbus-debug", &Vdbus_debug,
1293     doc: /* If non-nil, debug messages of D-Bus bindings are raised.  */);
1294 #ifdef DBUS_DEBUG
1295   Vdbus_debug = Qt;
1296 #else
1297   Vdbus_debug = Qnil;
1298 #endif
1299
1300   Fprovide (intern ("dbusbind"), Qnil);
1301
1302 }
1303
1304 #endif /* HAVE_DBUS */
1305
1306 /* arch-tag: 0e828477-b571-4fe4-b559-5c9211bc14b8
1307    (do not change this comment) */