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_method_return_internal;
  37 Lisp_Object Qdbus_send_signal;
  38 Lisp_Object Qdbus_register_signal;
  39 Lisp_Object Qdbus_register_method;
  40
  41 /* D-Bus error symbol.  */
  42 Lisp_Object Qdbus_error;
  43
  44 /* Lisp symbols of the system and session buses.  */
  45 Lisp_Object QCdbus_system_bus, QCdbus_session_bus;
  46
  47 /* Lisp 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 (CAR_SAFE (object)))           \
 163                          ? XD_SYMBOL_TO_DBUS_TYPE (CAR_SAFE (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 (CAR_SAFE (object))) ? CDR_SAFE (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       /* Type symbol is optional.  */
 232       if (EQ (QCdbus_type_array, CAR_SAFE (elt)))
 233         elt = XD_NEXT_VALUE (elt);
 234
 235       /* If the array is empty, DBUS_TYPE_STRING is the default
 236          element type.  */
 237       if (NILP (elt))
 238         {
 239           subtype = DBUS_TYPE_STRING;
 240           strcpy (x, DBUS_TYPE_STRING_AS_STRING);
 241         }
 242       else
 243         {
 244           subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
 245           xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
 246         }
 247
 248       /* If the element type is DBUS_TYPE_SIGNATURE, and this is the
 249          only element, the value of this element is used as he array's
 250          element signature.  */
 251       if ((subtype == DBUS_TYPE_SIGNATURE)
 252           && STRINGP (CAR_SAFE (XD_NEXT_VALUE (elt)))
 253           && NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
 254         strcpy (x, SDATA (CAR_SAFE (XD_NEXT_VALUE (elt))));
 255
 256       while (!NILP (elt))
 257         {
 258           if (subtype != XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt)))
 259             wrong_type_argument (intern ("D-Bus"), CAR_SAFE (elt));
 260           elt = CDR_SAFE (XD_NEXT_VALUE (elt));
 261         }
 262
 263       sprintf (signature, "%c%s", dtype, x);
 264       break;
 265
 266     case DBUS_TYPE_VARIANT:
 267       /* Check that there is exactly one list element.  */
 268       CHECK_CONS (object);
 269
 270       elt = XD_NEXT_VALUE (elt);
 271       subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
 272       xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
 273
 274       if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
 275         wrong_type_argument (intern ("D-Bus"),
 276                              CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt))));
 277
 278       sprintf (signature, "%c", dtype);
 279       break;
 280
 281     case DBUS_TYPE_STRUCT:
 282       /* A struct list might contain any number of elements with
 283          different types.  No further check needed.  */
 284       CHECK_CONS (object);
 285
 286       elt = XD_NEXT_VALUE (elt);
 287
 288       /* Compose the signature from the elements.  It is enclosed by
 289          parentheses.  */
 290       sprintf (signature, "%c", DBUS_STRUCT_BEGIN_CHAR );
 291       while (!NILP (elt))
 292         {
 293           subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
 294           xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
 295           strcat (signature, x);
 296           elt = CDR_SAFE (XD_NEXT_VALUE (elt));
 297         }
 298       sprintf (signature, "%s%c", signature, DBUS_STRUCT_END_CHAR);
 299       break;
 300
 301     case DBUS_TYPE_DICT_ENTRY:
 302       /* Check that there are exactly two list elements, and the first
 303          one is of basic type.  The dictionary entry itself must be an
 304          element of an array.  */
 305       CHECK_CONS (object);
 306
 307       /* Check the parent object type.  */
 308       if (parent_type != DBUS_TYPE_ARRAY)
 309         wrong_type_argument (intern ("D-Bus"), object);
 310
 311       /* Compose the signature from the elements.  It is enclosed by
 312          curly braces.  */
 313       sprintf (signature, "%c", DBUS_DICT_ENTRY_BEGIN_CHAR);
 314
 315       /* First element.  */
 316       elt = XD_NEXT_VALUE (elt);
 317       subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
 318       xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
 319       strcat (signature, x);
 320
 321       if (!XD_BASIC_DBUS_TYPE (subtype))
 322         wrong_type_argument (intern ("D-Bus"), CAR_SAFE (XD_NEXT_VALUE (elt)));
 323
 324       /* Second element.  */
 325       elt = CDR_SAFE (XD_NEXT_VALUE (elt));
 326       subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
 327       xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
 328       strcat (signature, x);
 329
 330       if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
 331         wrong_type_argument (intern ("D-Bus"),
 332                              CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt))));
 333
 334       /* Closing signature.  */
 335       sprintf (signature, "%s%c", signature, DBUS_DICT_ENTRY_END_CHAR);
 336       break;
 337
 338     default:
 339       wrong_type_argument (intern ("D-Bus"), object);
 340     }
 341
 342   XD_DEBUG_MESSAGE ("%s", signature);
 343 }
 344
 345 /* Append C value, extracted from Lisp OBJECT, to iteration ITER.
 346    DTYPE must be a valid DBusType.  It is used to convert Lisp
 347    objects, being arguments of `dbus-call-method' or
 348    `dbus-send-signal', into corresponding C values appended as
 349    arguments to a D-Bus message.  */
 350 void
 351 xd_append_arg (dtype, object, iter)
 352      unsigned int dtype;
 353      Lisp_Object object;
 354      DBusMessageIter *iter;
 355 {
 356   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
 357   DBusMessageIter subiter;
 358
 359   if (XD_BASIC_DBUS_TYPE (dtype))
 360     switch (dtype)
 361       {
 362       case DBUS_TYPE_BYTE:
 363         {
 364           unsigned char val = XUINT (object) & 0xFF;
 365           XD_DEBUG_MESSAGE ("%c %d", dtype, 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_BOOLEAN:
 373         {
 374           dbus_bool_t val = (NILP (object)) ? FALSE : TRUE;
 375           XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true");
 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_INT16:
 383         {
 384           dbus_int16_t val = XINT (object);
 385           XD_DEBUG_MESSAGE ("%c %d", dtype, (int) 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_UINT16:
 393         {
 394           dbus_uint16_t val = XUINT (object);
 395           XD_DEBUG_MESSAGE ("%c %u", dtype, (unsigned int) 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_INT32:
 403         {
 404           dbus_int32_t val = XINT (object);
 405           XD_DEBUG_MESSAGE ("%c %d", dtype, 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_UINT32:
 413         {
 414           dbus_uint32_t val = XUINT (object);
 415           XD_DEBUG_MESSAGE ("%c %u", dtype, 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_INT64:
 423         {
 424           dbus_int64_t val = XINT (object);
 425           XD_DEBUG_MESSAGE ("%c %d", dtype, (int) val);
 426           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 427             xsignal2 (Qdbus_error,
 428                       build_string ("Unable to append argument"), object);
 429           return;
 430         }
 431
 432       case DBUS_TYPE_UINT64:
 433         {
 434           dbus_uint64_t val = XUINT (object);
 435           XD_DEBUG_MESSAGE ("%c %u", dtype, (unsigned int) 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       case DBUS_TYPE_DOUBLE:
 443         XD_DEBUG_MESSAGE ("%c %f", dtype, XFLOAT_DATA (object));
 444         if (!dbus_message_iter_append_basic (iter, dtype,
 445                                              &XFLOAT_DATA (object)))
 446           xsignal2 (Qdbus_error,
 447                     build_string ("Unable to append argument"), object);
 448         return;
 449
 450       case DBUS_TYPE_STRING:
 451       case DBUS_TYPE_OBJECT_PATH:
 452       case DBUS_TYPE_SIGNATURE:
 453         {
 454           char *val = SDATA (object);
 455           XD_DEBUG_MESSAGE ("%c %s", dtype, val);
 456           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 457             xsignal2 (Qdbus_error,
 458                       build_string ("Unable to append argument"), object);
 459           return;
 460         }
 461       }
 462
 463   else /* Compound types.  */
 464     {
 465
 466       /* All compound types except array have a type symbol.  For
 467          array, it is optional.  Skip it.  */
 468       if (!XD_BASIC_DBUS_TYPE (XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object))))
 469         object = XD_NEXT_VALUE (object);
 470
 471       /* Open new subiteration.  */
 472       switch (dtype)
 473         {
 474         case DBUS_TYPE_ARRAY:
 475           /* An array has only elements of the same type.  So it is
 476              sufficient to check the first element's signature
 477              only.  */
 478
 479           if (NILP (object))
 480             /* If the array is empty, DBUS_TYPE_STRING is the default
 481                element type.  */
 482             strcpy (signature, DBUS_TYPE_STRING_AS_STRING);
 483
 484           else
 485             /* If the element type is DBUS_TYPE_SIGNATURE, and this is
 486                the only element, the value of this element is used as
 487                the array's element signature.  */
 488             if ((XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object))
 489                  == DBUS_TYPE_SIGNATURE)
 490                 && STRINGP (CAR_SAFE (XD_NEXT_VALUE (object)))
 491                 && NILP (CDR_SAFE (XD_NEXT_VALUE (object))))
 492               {
 493                 strcpy (signature, SDATA (CAR_SAFE (XD_NEXT_VALUE (object))));
 494                 object = CDR_SAFE (XD_NEXT_VALUE (object));
 495               }
 496
 497             else
 498               xd_signature (signature,
 499                             XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object)),
 500                             dtype, CAR_SAFE (XD_NEXT_VALUE (object)));
 501
 502           XD_DEBUG_MESSAGE ("%c %s %s", dtype, signature,
 503                             SDATA (format2 ("%s", object, Qnil)));
 504           if (!dbus_message_iter_open_container (iter, dtype,
 505                                                  signature, &subiter))
 506             xsignal3 (Qdbus_error,
 507                       build_string ("Cannot open container"),
 508                       make_number (dtype), build_string (signature));
 509           break;
 510
 511         case DBUS_TYPE_VARIANT:
 512           /* A variant has just one element.  */
 513           xd_signature (signature, XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object)),
 514                         dtype, CAR_SAFE (XD_NEXT_VALUE (object)));
 515
 516           XD_DEBUG_MESSAGE ("%c %s %s", dtype, signature,
 517                             SDATA (format2 ("%s", object, Qnil)));
 518           if (!dbus_message_iter_open_container (iter, dtype,
 519                                                  signature, &subiter))
 520             xsignal3 (Qdbus_error,
 521                       build_string ("Cannot open container"),
 522                       make_number (dtype), build_string (signature));
 523           break;
 524
 525         case DBUS_TYPE_STRUCT:
 526         case DBUS_TYPE_DICT_ENTRY:
 527           /* These containers do not require a signature.  */
 528           XD_DEBUG_MESSAGE ("%c %s", dtype,
 529                             SDATA (format2 ("%s", object, Qnil)));
 530           if (!dbus_message_iter_open_container (iter, dtype, NULL, &subiter))
 531             xsignal2 (Qdbus_error,
 532                       build_string ("Cannot open container"),
 533                       make_number (dtype));
 534           break;
 535         }
 536
 537       /* Loop over list elements.  */
 538       while (!NILP (object))
 539         {
 540           dtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object));
 541           object = XD_NEXT_VALUE (object);
 542
 543           xd_append_arg (dtype, CAR_SAFE (object), &subiter);
 544
 545           object = CDR_SAFE (object);
 546         }
 547
 548       /* Close the subiteration.  */
 549       if (!dbus_message_iter_close_container (iter, &subiter))
 550         xsignal2 (Qdbus_error,
 551                   build_string ("Cannot close container"),
 552                   make_number (dtype));
 553     }
 554 }
 555
 556 /* Retrieve C value from a DBusMessageIter structure ITER, and return
 557    a converted Lisp object.  The type DTYPE of the argument of the
 558    D-Bus message must be a valid DBusType.  Compound D-Bus types
 559    result always in a Lisp list.  */
 560 Lisp_Object
 561 xd_retrieve_arg (dtype, iter)
 562      unsigned int dtype;
 563      DBusMessageIter *iter;
 564 {
 565
 566   switch (dtype)
 567     {
 568     case DBUS_TYPE_BYTE:
 569       {
 570         unsigned int val;
 571         dbus_message_iter_get_basic (iter, &val);
 572         val = val & 0xFF;
 573         XD_DEBUG_MESSAGE ("%c %d", dtype, val);
 574         return make_number (val);
 575       }
 576
 577     case DBUS_TYPE_BOOLEAN:
 578       {
 579         dbus_bool_t val;
 580         dbus_message_iter_get_basic (iter, &val);
 581         XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true");
 582         return (val == FALSE) ? Qnil : Qt;
 583       }
 584
 585     case DBUS_TYPE_INT16:
 586     case DBUS_TYPE_UINT16:
 587       {
 588         dbus_uint16_t val;
 589         dbus_message_iter_get_basic (iter, &val);
 590         XD_DEBUG_MESSAGE ("%c %d", dtype, val);
 591         return make_number (val);
 592       }
 593
 594     case DBUS_TYPE_INT32:
 595     case DBUS_TYPE_UINT32:
 596       {
 597         /* Assignment to EMACS_INT stops GCC whining about limited
 598            range of data type.  */
 599         dbus_uint32_t val;
 600         EMACS_INT val1;
 601         dbus_message_iter_get_basic (iter, &val);
 602         XD_DEBUG_MESSAGE ("%c %d", dtype, val);
 603         val1 = val;
 604         return make_fixnum_or_float (val1);
 605       }
 606
 607     case DBUS_TYPE_INT64:
 608     case DBUS_TYPE_UINT64:
 609       {
 610         dbus_uint64_t val;
 611         dbus_message_iter_get_basic (iter, &val);
 612         XD_DEBUG_MESSAGE ("%c %d", dtype, (int) val);
 613         return make_fixnum_or_float (val);
 614       }
 615
 616     case DBUS_TYPE_DOUBLE:
 617       {
 618         double val;
 619         dbus_message_iter_get_basic (iter, &val);
 620         XD_DEBUG_MESSAGE ("%c %f", dtype, val);
 621         return make_float (val);
 622       }
 623
 624     case DBUS_TYPE_STRING:
 625     case DBUS_TYPE_OBJECT_PATH:
 626     case DBUS_TYPE_SIGNATURE:
 627       {
 628         char *val;
 629         dbus_message_iter_get_basic (iter, &val);
 630         XD_DEBUG_MESSAGE ("%c %s", dtype, val);
 631         return build_string (val);
 632       }
 633
 634     case DBUS_TYPE_ARRAY:
 635     case DBUS_TYPE_VARIANT:
 636     case DBUS_TYPE_STRUCT:
 637     case DBUS_TYPE_DICT_ENTRY:
 638       {
 639         Lisp_Object result;
 640         struct gcpro gcpro1;
 641         result = Qnil;
 642         GCPRO1 (result);
 643         DBusMessageIter subiter;
 644         int subtype;
 645         dbus_message_iter_recurse (iter, &subiter);
 646         while ((subtype = dbus_message_iter_get_arg_type (&subiter))
 647                != DBUS_TYPE_INVALID)
 648           {
 649             result = Fcons (xd_retrieve_arg (subtype, &subiter), result);
 650             dbus_message_iter_next (&subiter);
 651           }
 652         XD_DEBUG_MESSAGE ("%c %s", dtype, SDATA (format2 ("%s", result, Qnil)));
 653         RETURN_UNGCPRO (Fnreverse (result));
 654       }
 655
 656     default:
 657       XD_DEBUG_MESSAGE ("DBusType '%c' not supported", dtype);
 658       return Qnil;
 659     }
 660 }
 661
 662 /* Initialize D-Bus connection.  BUS is a Lisp symbol, either :system
 663    or :session.  It tells which D-Bus to be initialized.  */
 664 DBusConnection *
 665 xd_initialize (bus)
 666      Lisp_Object bus;
 667 {
 668   DBusConnection *connection;
 669   DBusError derror;
 670
 671   /* Parameter check.  */
 672   CHECK_SYMBOL (bus);
 673   if (!((EQ (bus, QCdbus_system_bus)) || (EQ (bus, QCdbus_session_bus))))
 674     xsignal2 (Qdbus_error, build_string ("Wrong bus name"), bus);
 675
 676   /* Open a connection to the bus.  */
 677   dbus_error_init (&derror);
 678
 679   if (EQ (bus, QCdbus_system_bus))
 680     connection = dbus_bus_get (DBUS_BUS_SYSTEM, &derror);
 681   else
 682     connection = dbus_bus_get (DBUS_BUS_SESSION, &derror);
 683
 684   if (dbus_error_is_set (&derror))
 685     XD_ERROR (derror);
 686
 687   if (connection == NULL)
 688     xsignal2 (Qdbus_error, build_string ("No connection"), bus);
 689
 690   /* Return the result.  */
 691   return connection;
 692 }
 693
 694 DEFUN ("dbus-get-unique-name", Fdbus_get_unique_name, Sdbus_get_unique_name,
 695        1, 1, 0,
 696        doc: /* Return the unique name of Emacs registered at D-Bus BUS.  */)
 697      (bus)
 698      Lisp_Object bus;
 699 {
 700   DBusConnection *connection;
 701   char name[DBUS_MAXIMUM_NAME_LENGTH];
 702
 703   /* Check parameters.  */
 704   CHECK_SYMBOL (bus);
 705
 706   /* Open a connection to the bus.  */
 707   connection = xd_initialize (bus);
 708
 709   /* Request the name.  */
 710   strcpy (name, dbus_bus_get_unique_name (connection));
 711   if (name == NULL)
 712     xsignal1 (Qdbus_error, build_string ("No unique name available"));
 713
 714   /* Return.  */
 715   return build_string (name);
 716 }
 717
 718 DEFUN ("dbus-call-method", Fdbus_call_method, Sdbus_call_method, 5, MANY, 0,
 719        doc: /* Call METHOD on the D-Bus BUS.
 720
 721 BUS is either the symbol `:system' or the symbol `:session'.
 722
 723 SERVICE is the D-Bus service name to be used.  PATH is the D-Bus
 724 object path SERVICE is registered at.  INTERFACE is an interface
 725 offered by SERVICE.  It must provide METHOD.
 726
 727 All other arguments ARGS are passed to METHOD as arguments.  They are
 728 converted into D-Bus types via the following rules:
 729
 730   t and nil => DBUS_TYPE_BOOLEAN
 731   number    => DBUS_TYPE_UINT32
 732   integer   => DBUS_TYPE_INT32
 733   float     => DBUS_TYPE_DOUBLE
 734   string    => DBUS_TYPE_STRING
 735   list      => DBUS_TYPE_ARRAY
 736
 737 All arguments can be preceded by a type symbol.  For details about
 738 type symbols, see Info node `(dbus)Type Conversion'.
 739
 740 `dbus-call-method' returns the resulting values of METHOD as a list of
 741 Lisp objects.  The type conversion happens the other direction as for
 742 input arguments.  It follows the mapping rules:
 743
 744   DBUS_TYPE_BOOLEAN     => t or nil
 745   DBUS_TYPE_BYTE        => number
 746   DBUS_TYPE_UINT16      => number
 747   DBUS_TYPE_INT16       => integer
 748   DBUS_TYPE_UINT32      => number or float
 749   DBUS_TYPE_INT32       => integer or float
 750   DBUS_TYPE_UINT64      => number or float
 751   DBUS_TYPE_INT64       => integer or float
 752   DBUS_TYPE_DOUBLE      => float
 753   DBUS_TYPE_STRING      => string
 754   DBUS_TYPE_OBJECT_PATH => string
 755   DBUS_TYPE_SIGNATURE   => string
 756   DBUS_TYPE_ARRAY       => list
 757   DBUS_TYPE_VARIANT     => list
 758   DBUS_TYPE_STRUCT      => list
 759   DBUS_TYPE_DICT_ENTRY  => list
 760
 761 Example:
 762
 763 \(dbus-call-method
 764   :session "org.gnome.seahorse" "/org/gnome/seahorse/keys/openpgp"
 765   "org.gnome.seahorse.Keys" "GetKeyField"
 766   "openpgp:657984B8C7A966DD" "simple-name")
 767
 768   => (t ("Philip R. Zimmermann"))
 769
 770 If the result of the METHOD call is just one value, the converted Lisp
 771 object is returned instead of a list containing this single Lisp object.
 772
 773 \(dbus-call-method
 774   :system "org.freedesktop.Hal" "/org/freedesktop/Hal/devices/computer"
 775   "org.freedesktop.Hal.Device" "GetPropertyString"
 776   "system.kernel.machine")
 777
 778   => "i686"
 779
 780 usage: (dbus-call-method BUS SERVICE PATH INTERFACE METHOD &rest ARGS)  */)
 781      (nargs, args)
 782      int nargs;
 783      register Lisp_Object *args;
 784 {
 785   Lisp_Object bus, service, path, interface, method;
 786   Lisp_Object result;
 787   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
 788   DBusConnection *connection;
 789   DBusMessage *dmessage;
 790   DBusMessage *reply;
 791   DBusMessageIter iter;
 792   DBusError derror;
 793   unsigned int dtype;
 794   int i;
 795   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
 796
 797   /* Check parameters.  */
 798   bus = args[0];
 799   service = args[1];
 800   path = args[2];
 801   interface = args[3];
 802   method = args[4];
 803
 804   CHECK_SYMBOL (bus);
 805   CHECK_STRING (service);
 806   CHECK_STRING (path);
 807   CHECK_STRING (interface);
 808   CHECK_STRING (method);
 809   GCPRO5 (bus, service, path, interface, method);
 810
 811   XD_DEBUG_MESSAGE ("%s %s %s %s",
 812                     SDATA (service),
 813                     SDATA (path),
 814                     SDATA (interface),
 815                     SDATA (method));
 816
 817   /* Open a connection to the bus.  */
 818   connection = xd_initialize (bus);
 819
 820   /* Create the message.  */
 821   dmessage = dbus_message_new_method_call (SDATA (service),
 822                                            SDATA (path),
 823                                            SDATA (interface),
 824                                            SDATA (method));
 825   if (dmessage == NULL)
 826     {
 827       UNGCPRO;
 828       xsignal1 (Qdbus_error, build_string ("Unable to create a new message"));
 829     }
 830
 831   UNGCPRO;
 832
 833   /* Initialize parameter list of message.  */
 834   dbus_message_iter_init_append (dmessage, &iter);
 835
 836   /* Append parameters to the message.  */
 837   for (i = 5; i < nargs; ++i)
 838     {
 839       dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
 840       if (XD_DBUS_TYPE_P (args[i]))
 841         {
 842           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
 843           XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
 844           XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-4,
 845                             SDATA (format2 ("%s", args[i], Qnil)),
 846                             SDATA (format2 ("%s", args[i+1], Qnil)));
 847           ++i;
 848         }
 849       else
 850         {
 851           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
 852           XD_DEBUG_MESSAGE ("Parameter%d %s", i-4,
 853                             SDATA (format2 ("%s", args[i], Qnil)));
 854         }
 855
 856       /* Check for valid signature.  We use DBUS_TYPE_INVALID as
 857          indication that there is no parent type.  */
 858       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
 859
 860       xd_append_arg (dtype, args[i], &iter);
 861     }
 862
 863   /* Send the message.  */
 864   dbus_error_init (&derror);
 865   reply = dbus_connection_send_with_reply_and_block (connection,
 866                                                      dmessage,
 867                                                      -1,
 868                                                      &derror);
 869
 870   if (dbus_error_is_set (&derror))
 871     XD_ERROR (derror);
 872
 873   if (reply == NULL)
 874     xsignal1 (Qdbus_error, build_string ("No reply"));
 875
 876   XD_DEBUG_MESSAGE ("Message sent");
 877
 878   /* Collect the results.  */
 879   result = Qnil;
 880   GCPRO1 (result);
 881
 882   if (dbus_message_iter_init (reply, &iter))
 883     {
 884       /* Loop over the parameters of the D-Bus reply message.  Construct a
 885          Lisp list, which is returned by `dbus-call-method'.  */
 886       while ((dtype = dbus_message_iter_get_arg_type (&iter))
 887              != DBUS_TYPE_INVALID)
 888         {
 889           result = Fcons (xd_retrieve_arg (dtype, &iter), result);
 890           dbus_message_iter_next (&iter);
 891         }
 892     }
 893   else
 894     {
 895       /* No arguments: just return nil.  */
 896     }
 897
 898   /* Cleanup.  */
 899   dbus_message_unref (dmessage);
 900   dbus_message_unref (reply);
 901
 902   /* Return the result.  If there is only one single Lisp object,
 903      return it as-it-is, otherwise return the reversed list.  */
 904   if (XUINT (Flength (result)) == 1)
 905     RETURN_UNGCPRO (CAR_SAFE (result));
 906   else
 907     RETURN_UNGCPRO (Fnreverse (result));
 908 }
 909
 910 DEFUN ("dbus-method-return-internal", Fdbus_method_return_internal,
 911        Sdbus_method_return_internal,
 912        3, MANY, 0,
 913        doc: /* Return for message SERIAL on the D-Bus BUS.
 914 This is an internal function, it shall not be used outside dbus.el.
 915
 916 usage: (dbus-method-return-internal BUS SERIAL SERVICE &rest ARGS)  */)
 917      (nargs, args)
 918      int nargs;
 919      register Lisp_Object *args;
 920 {
 921   Lisp_Object bus, serial, service;
 922   struct gcpro gcpro1, gcpro2, gcpro3;
 923   DBusConnection *connection;
 924   DBusMessage *dmessage;
 925   DBusMessageIter iter;
 926   unsigned int dtype;
 927   int i;
 928   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
 929
 930   /* Check parameters.  */
 931   bus = args[0];
 932   serial = args[1];
 933   service = args[2];
 934
 935   CHECK_SYMBOL (bus);
 936   CHECK_NUMBER (serial);
 937   CHECK_STRING (service);
 938   GCPRO3 (bus, serial, service);
 939
 940   XD_DEBUG_MESSAGE ("%d %s ", XUINT (serial), SDATA (service));
 941
 942   /* Open a connection to the bus.  */
 943   connection = xd_initialize (bus);
 944
 945   /* Create the message.  */
 946   dmessage = dbus_message_new (DBUS_MESSAGE_TYPE_METHOD_RETURN);
 947   if ((dmessage == NULL)
 948       || (!dbus_message_set_reply_serial (dmessage, XUINT (serial)))
 949       || (!dbus_message_set_destination (dmessage, SDATA (service))))
 950     {
 951       UNGCPRO;
 952       xsignal1 (Qdbus_error,
 953                 build_string ("Unable to create a return message"));
 954     }
 955
 956   UNGCPRO;
 957
 958   /* Initialize parameter list of message.  */
 959   dbus_message_iter_init_append (dmessage, &iter);
 960
 961   /* Append parameters to the message.  */
 962   for (i = 3; i < nargs; ++i)
 963     {
 964       dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
 965       if (XD_DBUS_TYPE_P (args[i]))
 966         {
 967           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
 968           XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
 969           XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-2,
 970                             SDATA (format2 ("%s", args[i], Qnil)),
 971                             SDATA (format2 ("%s", args[i+1], Qnil)));
 972           ++i;
 973         }
 974       else
 975         {
 976           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
 977           XD_DEBUG_MESSAGE ("Parameter%d %s", i-2,
 978                             SDATA (format2 ("%s", args[i], Qnil)));
 979         }
 980
 981       /* Check for valid signature.  We use DBUS_TYPE_INVALID as
 982          indication that there is no parent type.  */
 983       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
 984
 985       xd_append_arg (dtype, args[i], &iter);
 986     }
 987
 988   /* Send the message.  The message is just added to the outgoing
 989      message queue.  */
 990   if (!dbus_connection_send (connection, dmessage, NULL))
 991     xsignal1 (Qdbus_error, build_string ("Cannot send message"));
 992
 993   /* Flush connection to ensure the message is handled.  */
 994   dbus_connection_flush (connection);
 995
 996   XD_DEBUG_MESSAGE ("Message sent");
 997
 998   /* Cleanup.  */
 999   dbus_message_unref (dmessage);
1000
1001   /* Return.  */
1002   return Qt;
1003 }
1004
1005 DEFUN ("dbus-send-signal", Fdbus_send_signal, Sdbus_send_signal, 5, MANY, 0,
1006        doc: /* Send signal SIGNAL on the D-Bus BUS.
1007
1008 BUS is either the symbol `:system' or the symbol `:session'.
1009
1010 SERVICE is the D-Bus service name SIGNAL is sent from.  PATH is the
1011 D-Bus object path SERVICE is registered at.  INTERFACE is an interface
1012 offered by SERVICE.  It must provide signal SIGNAL.
1013
1014 All other arguments ARGS are passed to SIGNAL as arguments.  They are
1015 converted into D-Bus types via the following rules:
1016
1017   t and nil => DBUS_TYPE_BOOLEAN
1018   number    => DBUS_TYPE_UINT32
1019   integer   => DBUS_TYPE_INT32
1020   float     => DBUS_TYPE_DOUBLE
1021   string    => DBUS_TYPE_STRING
1022   list      => DBUS_TYPE_ARRAY
1023
1024 All arguments can be preceded by a type symbol.  For details about
1025 type symbols, see Info node `(dbus)Type Conversion'.
1026
1027 Example:
1028
1029 \(dbus-send-signal
1030   :session "org.gnu.Emacs" "/org/gnu/Emacs"
1031   "org.gnu.Emacs.FileManager" "FileModified" "/home/albinus/.emacs")
1032
1033 usage: (dbus-send-signal BUS SERVICE PATH INTERFACE SIGNAL &rest ARGS)  */)
1034      (nargs, args)
1035      int nargs;
1036      register Lisp_Object *args;
1037 {
1038   Lisp_Object bus, service, path, interface, signal;
1039   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
1040   DBusConnection *connection;
1041   DBusMessage *dmessage;
1042   DBusMessageIter iter;
1043   unsigned int dtype;
1044   int i;
1045   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1046
1047   /* Check parameters.  */
1048   bus = args[0];
1049   service = args[1];
1050   path = args[2];
1051   interface = args[3];
1052   signal = args[4];
1053
1054   CHECK_SYMBOL (bus);
1055   CHECK_STRING (service);
1056   CHECK_STRING (path);
1057   CHECK_STRING (interface);
1058   CHECK_STRING (signal);
1059   GCPRO5 (bus, service, path, interface, signal);
1060
1061   XD_DEBUG_MESSAGE ("%s %s %s %s",
1062                     SDATA (service),
1063                     SDATA (path),
1064                     SDATA (interface),
1065                     SDATA (signal));
1066
1067   /* Open a connection to the bus.  */
1068   connection = xd_initialize (bus);
1069
1070   /* Create the message.  */
1071   dmessage = dbus_message_new_signal (SDATA (path),
1072                                       SDATA (interface),
1073                                       SDATA (signal));
1074   if (dmessage == NULL)
1075     {
1076       UNGCPRO;
1077       xsignal1 (Qdbus_error, build_string ("Unable to create a new message"));
1078     }
1079
1080   UNGCPRO;
1081
1082   /* Initialize parameter list of message.  */
1083   dbus_message_iter_init_append (dmessage, &iter);
1084
1085   /* Append parameters to the message.  */
1086   for (i = 5; i < nargs; ++i)
1087     {
1088       dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1089       if (XD_DBUS_TYPE_P (args[i]))
1090         {
1091           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1092           XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1093           XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-4,
1094                             SDATA (format2 ("%s", args[i], Qnil)),
1095                             SDATA (format2 ("%s", args[i+1], Qnil)));
1096           ++i;
1097         }
1098       else
1099         {
1100           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1101           XD_DEBUG_MESSAGE ("Parameter%d %s", i-4,
1102                             SDATA (format2 ("%s", args[i], Qnil)));
1103         }
1104
1105       /* Check for valid signature.  We use DBUS_TYPE_INVALID as
1106          indication that there is no parent type.  */
1107       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1108
1109       xd_append_arg (dtype, args[i], &iter);
1110     }
1111
1112   /* Send the message.  The message is just added to the outgoing
1113      message queue.  */
1114   if (!dbus_connection_send (connection, dmessage, NULL))
1115     xsignal1 (Qdbus_error, build_string ("Cannot send message"));
1116
1117   /* Flush connection to ensure the message is handled.  */
1118   dbus_connection_flush (connection);
1119
1120   XD_DEBUG_MESSAGE ("Signal sent");
1121
1122   /* Cleanup.  */
1123   dbus_message_unref (dmessage);
1124
1125   /* Return.  */
1126   return Qt;
1127 }
1128
1129 /* Read queued incoming message of the D-Bus BUS.  BUS is a Lisp
1130    symbol, either :system or :session.  */
1131 Lisp_Object
1132 xd_read_message (bus)
1133      Lisp_Object bus;
1134 {
1135   Lisp_Object args, key, value;
1136   struct gcpro gcpro1;
1137   struct input_event event;
1138   DBusConnection *connection;
1139   DBusMessage *dmessage;
1140   DBusMessageIter iter;
1141   unsigned int dtype;
1142   int mtype;
1143   const char *uname, *path, *interface, *member;
1144
1145   /* Open a connection to the bus.  */
1146   connection = xd_initialize (bus);
1147
1148   /* Non blocking read of the next available message.  */
1149   dbus_connection_read_write (connection, 0);
1150   dmessage = dbus_connection_pop_message (connection);
1151
1152   /* Return if there is no queued message.  */
1153   if (dmessage == NULL)
1154     return Qnil;
1155
1156   /* Collect the parameters.  */
1157   args = Qnil;
1158   GCPRO1 (args);
1159
1160   /* Loop over the resulting parameters.  Construct a list.  */
1161   if (dbus_message_iter_init (dmessage, &iter))
1162     {
1163       while ((dtype = dbus_message_iter_get_arg_type (&iter))
1164              != DBUS_TYPE_INVALID)
1165         {
1166           args = Fcons (xd_retrieve_arg (dtype, &iter), args);
1167           dbus_message_iter_next (&iter);
1168         }
1169       /* The arguments are stored in reverse order.  Reorder them.  */
1170       args = Fnreverse (args);
1171     }
1172
1173   /* Read message type, unique name, object path, interface and member
1174      from the message.  */
1175   mtype     = dbus_message_get_type (dmessage);
1176   uname     = dbus_message_get_sender (dmessage);
1177   path      = dbus_message_get_path (dmessage);
1178   interface = dbus_message_get_interface (dmessage);
1179   member    = dbus_message_get_member (dmessage);
1180
1181   /* dbus-registered-functions-table requires non nil interface and member. */
1182   if ((NULL == interface) || (NULL == member))
1183     goto cleanup;
1184
1185   XD_DEBUG_MESSAGE ("Event received: %d %s %s %s %s %s",
1186                     mtype, uname, path, interface, member,
1187                     SDATA (format2 ("%s", args, Qnil)));
1188
1189   /* Search for a registered function of the message.  */
1190   key = list3 (bus, build_string (interface), build_string (member));
1191   value = Fgethash (key, Vdbus_registered_functions_table, Qnil);
1192
1193   /* Loop over the registered functions.  Construct an event.  */
1194   while (!NILP (value))
1195     {
1196       key = CAR_SAFE (value);
1197       /* key has the structure (UNAME SERVICE PATH HANDLER).  */
1198       if (((uname == NULL)
1199            || (NILP (CAR_SAFE (key)))
1200            || (strcmp (uname, SDATA (CAR_SAFE (key))) == 0))
1201           && ((path == NULL)
1202               || (NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1203               || (strcmp (path, SDATA (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1204                   == 0))
1205           && (!NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))))))
1206         {
1207           EVENT_INIT (event);
1208           event.kind = DBUS_EVENT;
1209           event.frame_or_window = Qnil;
1210           event.arg = Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))),
1211                              args);
1212
1213           /* Add uname, path, interface and member to the event.  */
1214           event.arg = Fcons (build_string (member), event.arg);
1215           event.arg = Fcons (build_string (interface), event.arg);
1216           event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
1217                              event.arg);
1218           event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
1219                              event.arg);
1220
1221           /* Add the message serial if needed, or nil.  */
1222           event.arg = Fcons ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL
1223                               ? make_number (dbus_message_get_serial (dmessage))
1224                               : Qnil),
1225                              event.arg);
1226
1227           /* Add the bus symbol to the event.  */
1228           event.arg = Fcons (bus, event.arg);
1229
1230           /* Store it into the input event queue.  */
1231           kbd_buffer_store_event (&event);
1232         }
1233      value = CDR_SAFE (value);
1234     }
1235
1236  cleanup:
1237   dbus_message_unref (dmessage);
1238   RETURN_UNGCPRO (Qnil);
1239 }
1240
1241 /* Read queued incoming messages from the system and session buses.  */
1242 void
1243 xd_read_queued_messages ()
1244 {
1245
1246   /* Vdbus_registered_functions_table will be initialized as hash
1247      table in dbus.el.  When this package isn't loaded yet, it doesn't
1248      make sense to handle D-Bus messages.  Furthermore, we ignore all
1249      Lisp errors during the call.  */
1250   if (HASH_TABLE_P (Vdbus_registered_functions_table))
1251     {
1252       internal_condition_case_1 (xd_read_message, QCdbus_system_bus,
1253                                  Qerror, Fidentity);
1254       internal_condition_case_1 (xd_read_message, QCdbus_session_bus,
1255                                  Qerror, Fidentity);
1256     }
1257 }
1258
1259 DEFUN ("dbus-register-signal", Fdbus_register_signal, Sdbus_register_signal,
1260        6, 6, 0,
1261        doc: /* Register for signal SIGNAL on the D-Bus BUS.
1262
1263 BUS is either the symbol `:system' or the symbol `:session'.
1264
1265 SERVICE is the D-Bus service name used by the sending D-Bus object.
1266 It can be either a known name or the unique name of the D-Bus object
1267 sending the signal.  When SERVICE is nil, related signals from all
1268 D-Bus objects shall be accepted.
1269
1270 PATH is the D-Bus object path SERVICE is registered.  It can also be
1271 nil if the path name of incoming signals shall not be checked.
1272
1273 INTERFACE is an interface offered by SERVICE.  It must provide SIGNAL.
1274 HANDLER is a Lisp function to be called when the signal is received.
1275 It must accept as arguments the values SIGNAL is sending.  INTERFACE,
1276 SIGNAL and HANDLER must not be nil.  Example:
1277
1278 \(defun my-signal-handler (device)
1279   (message "Device %s added" device))
1280
1281 \(dbus-register-signal
1282   :system "org.freedesktop.Hal" "/org/freedesktop/Hal/Manager"
1283   "org.freedesktop.Hal.Manager" "DeviceAdded" 'my-signal-handler)
1284
1285   => ((:system "org.freedesktop.Hal.Manager" "DeviceAdded")
1286       ("org.freedesktop.Hal" "/org/freedesktop/Hal/Manager" my-signal-handler))
1287
1288 `dbus-register-signal' returns an object, which can be used in
1289 `dbus-unregister-object' for removing the registration.  */)
1290      (bus, service, path, interface, signal, handler)
1291      Lisp_Object bus, service, path, interface, signal, handler;
1292 {
1293   Lisp_Object uname, key, key1, value;
1294   DBusConnection *connection;
1295   char rule[DBUS_MAXIMUM_MATCH_RULE_LENGTH];
1296   DBusError derror;
1297
1298   /* Check parameters.  */
1299   CHECK_SYMBOL (bus);
1300   if (!NILP (service)) CHECK_STRING (service);
1301   if (!NILP (path)) CHECK_STRING (path);
1302   CHECK_STRING (interface);
1303   CHECK_STRING (signal);
1304   if (!FUNCTIONP (handler))
1305     wrong_type_argument (intern ("functionp"), handler);
1306
1307   /* Retrieve unique name of service.  If service is a known name, we
1308      will register for the corresponding unique name, if any.  Signals
1309      are sent always with the unique name as sender.  Note: the unique
1310      name of "org.freedesktop.DBus" is that string itself.  */
1311   if ((STRINGP (service))
1312       && (SBYTES (service) > 0)
1313       && (strcmp (SDATA (service), DBUS_SERVICE_DBUS) != 0)
1314       && (strncmp (SDATA (service), ":", 1) != 0))
1315     {
1316       uname = call2 (intern ("dbus-get-name-owner"), bus, service);
1317       /* When there is no unique name, we mark it with an empty
1318          string.  */
1319       if (NILP (uname))
1320         uname = build_string ("");
1321     }
1322   else
1323     uname = service;
1324
1325   /* Create a matching rule if the unique name exists (when no
1326      wildcard).  */
1327   if (NILP (uname) || (SBYTES (uname) > 0))
1328     {
1329       /* Open a connection to the bus.  */
1330       connection = xd_initialize (bus);
1331
1332       /* Create a rule to receive related signals.  */
1333       sprintf (rule,
1334                "type='signal',interface='%s',member='%s'",
1335                SDATA (interface),
1336                SDATA (signal));
1337
1338       /* Add unique name and path to the rule if they are non-nil.  */
1339       if (!NILP (uname))
1340         sprintf (rule, "%s,sender='%s'", rule, SDATA (uname));
1341
1342       if (!NILP (path))
1343         sprintf (rule, "%s,path='%s'", rule, SDATA (path));
1344
1345       /* Add the rule to the bus.  */
1346       dbus_error_init (&derror);
1347       dbus_bus_add_match (connection, rule, &derror);
1348       if (dbus_error_is_set (&derror))
1349         XD_ERROR (derror);
1350
1351       XD_DEBUG_MESSAGE ("Matching rule \"%s\" created", rule);
1352     }
1353
1354   /* Create a hash table entry.  */
1355   key = list3 (bus, interface, signal);
1356   key1 = list4 (uname, service, path, handler);
1357   value = Fgethash (key, Vdbus_registered_functions_table, Qnil);
1358
1359   if (NILP (Fmember (key1, value)))
1360     Fputhash (key, Fcons (key1, value), Vdbus_registered_functions_table);
1361
1362   /* Return object.  */
1363   return list2 (key, list3 (service, path, handler));
1364 }
1365
1366 DEFUN ("dbus-register-method", Fdbus_register_method, Sdbus_register_method,
1367        6, 6, 0,
1368        doc: /* Register for method METHOD on the D-Bus BUS.
1369
1370 BUS is either the symbol `:system' or the symbol `:session'.
1371
1372 SERVICE is the D-Bus service name of the D-Bus object METHOD is
1373 registered for.  It must be a known name.
1374
1375 PATH is the D-Bus object path SERVICE is registered.  INTERFACE is the
1376 interface offered by SERVICE.  It must provide METHOD.  HANDLER is a
1377 Lisp function to be called when a method call is received.  It must
1378 accept the input arguments of METHOD.  The return value of HANDLER is
1379 used for composing the returning D-Bus message.  */)
1380      (bus, service, path, interface, method, handler)
1381      Lisp_Object bus, service, path, interface, method, handler;
1382 {
1383   Lisp_Object key, key1, value;
1384   DBusConnection *connection;
1385   int result;
1386   DBusError derror;
1387
1388   /* Check parameters.  */
1389   CHECK_SYMBOL (bus);
1390   CHECK_STRING (service);
1391   CHECK_STRING (path);
1392   CHECK_STRING (interface);
1393   CHECK_STRING (method);
1394   if (!FUNCTIONP (handler))
1395     wrong_type_argument (intern ("functionp"), handler);
1396   /* TODO: We must check for a valid service name, otherwise there is
1397      a segmentation fault.  */
1398
1399   /* Open a connection to the bus.  */
1400   connection = xd_initialize (bus);
1401
1402   /* Request the known name from the bus.  We can ignore the result,
1403      it is set to -1 if there is an error - kind of redundancy.  */
1404   dbus_error_init (&derror);
1405   result = dbus_bus_request_name (connection, SDATA (service), 0, &derror);
1406   if (dbus_error_is_set (&derror))
1407     XD_ERROR (derror);
1408
1409   /* Create a hash table entry.  */
1410   key = list3 (bus, interface, method);
1411   key1 = list4 (Qnil, service, path, handler);
1412   value = Fgethash (key, Vdbus_registered_functions_table, Qnil);
1413
1414   /* We use nil for the unique name, because the method might be
1415      called from everybody.  */
1416   if (NILP (Fmember (key1, value)))
1417     Fputhash (key, Fcons (key1, value), Vdbus_registered_functions_table);
1418
1419   /* Return object.  */
1420   return list2 (key, list3 (service, path, handler));
1421 }
1422
1423 \f
1424 void
1425 syms_of_dbusbind ()
1426 {
1427
1428   Qdbus_get_unique_name = intern ("dbus-get-unique-name");
1429   staticpro (&Qdbus_get_unique_name);
1430   defsubr (&Sdbus_get_unique_name);
1431
1432   Qdbus_call_method = intern ("dbus-call-method");
1433   staticpro (&Qdbus_call_method);
1434   defsubr (&Sdbus_call_method);
1435
1436   Qdbus_method_return_internal = intern ("dbus-method-return-internal");
1437   staticpro (&Qdbus_method_return_internal);
1438   defsubr (&Sdbus_method_return_internal);
1439
1440   Qdbus_send_signal = intern ("dbus-send-signal");
1441   staticpro (&Qdbus_send_signal);
1442   defsubr (&Sdbus_send_signal);
1443
1444   Qdbus_register_signal = intern ("dbus-register-signal");
1445   staticpro (&Qdbus_register_signal);
1446   defsubr (&Sdbus_register_signal);
1447
1448   Qdbus_register_method = intern ("dbus-register-method");
1449   staticpro (&Qdbus_register_method);
1450   defsubr (&Sdbus_register_method);
1451
1452   Qdbus_error = intern ("dbus-error");
1453   staticpro (&Qdbus_error);
1454   Fput (Qdbus_error, Qerror_conditions,
1455         list2 (Qdbus_error, Qerror));
1456   Fput (Qdbus_error, Qerror_message,
1457         build_string ("D-Bus error"));
1458
1459   QCdbus_system_bus = intern (":system");
1460   staticpro (&QCdbus_system_bus);
1461
1462   QCdbus_session_bus = intern (":session");
1463   staticpro (&QCdbus_session_bus);
1464
1465   QCdbus_type_byte = intern (":byte");
1466   staticpro (&QCdbus_type_byte);
1467
1468   QCdbus_type_boolean = intern (":boolean");
1469   staticpro (&QCdbus_type_boolean);
1470
1471   QCdbus_type_int16 = intern (":int16");
1472   staticpro (&QCdbus_type_int16);
1473
1474   QCdbus_type_uint16 = intern (":uint16");
1475   staticpro (&QCdbus_type_uint16);
1476
1477   QCdbus_type_int32 = intern (":int32");
1478   staticpro (&QCdbus_type_int32);
1479
1480   QCdbus_type_uint32 = intern (":uint32");
1481   staticpro (&QCdbus_type_uint32);
1482
1483   QCdbus_type_int64 = intern (":int64");
1484   staticpro (&QCdbus_type_int64);
1485
1486   QCdbus_type_uint64 = intern (":uint64");
1487   staticpro (&QCdbus_type_uint64);
1488
1489   QCdbus_type_double = intern (":double");
1490   staticpro (&QCdbus_type_double);
1491
1492   QCdbus_type_string = intern (":string");
1493   staticpro (&QCdbus_type_string);
1494
1495   QCdbus_type_object_path = intern (":object-path");
1496   staticpro (&QCdbus_type_object_path);
1497
1498   QCdbus_type_signature = intern (":signature");
1499   staticpro (&QCdbus_type_signature);
1500
1501   QCdbus_type_array = intern (":array");
1502   staticpro (&QCdbus_type_array);
1503
1504   QCdbus_type_variant = intern (":variant");
1505   staticpro (&QCdbus_type_variant);
1506
1507   QCdbus_type_struct = intern (":struct");
1508   staticpro (&QCdbus_type_struct);
1509
1510   QCdbus_type_dict_entry = intern (":dict-entry");
1511   staticpro (&QCdbus_type_dict_entry);
1512
1513   DEFVAR_LISP ("dbus-registered-functions-table",
1514                &Vdbus_registered_functions_table,
1515     doc: /* Hash table of registered functions for D-Bus.
1516 The key in the hash table is the list (BUS INTERFACE MEMBER).  BUS is
1517 either the symbol `:system' or the symbol `:session'.  INTERFACE is a
1518 string which denotes a D-Bus interface, and MEMBER, also a string, is
1519 either a method or a signal INTERFACE is offering.  All arguments but
1520 BUS must not be nil.
1521
1522 The value in the hash table is a list of quadruple lists
1523 \((UNAME SERVICE PATH HANDLER) (UNAME SERVICE PATH HANDLER) ...).
1524 SERVICE is the service name as registered, UNAME is the corresponding
1525 unique name.  PATH is the object path of the sending object.  All of
1526 them can be nil, which means a wildcard then.  HANDLER is the function
1527 to be called when a D-Bus message, which matches the key criteria,
1528 arrives.  */);
1529   /* We initialize Vdbus_registered_functions_table in dbus.el,
1530      because we need to define a hash table function first.  */
1531   Vdbus_registered_functions_table = Qnil;
1532
1533   DEFVAR_LISP ("dbus-debug", &Vdbus_debug,
1534     doc: /* If non-nil, debug messages of D-Bus bindings are raised.  */);
1535 #ifdef DBUS_DEBUG
1536   Vdbus_debug = Qt;
1537 #else
1538   Vdbus_debug = Qnil;
1539 #endif
1540
1541   Fprovide (intern ("dbusbind"), Qnil);
1542
1543 }
1544
1545 #endif /* HAVE_DBUS */
1546
1547 /* arch-tag: 0e828477-b571-4fe4-b559-5c9211bc14b8
1548    (do not change this comment) */