code.delx.au - gnu-emacs/blob - src/dbusbind.c

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