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   char uname[DBUS_MAXIMUM_NAME_LENGTH];
1144   char path[DBUS_MAXIMUM_MATCH_RULE_LENGTH]; /* Unlimited in D-Bus spec.  */
1145   char interface[DBUS_MAXIMUM_NAME_LENGTH];
1146   char member[DBUS_MAXIMUM_NAME_LENGTH];
1147
1148   /* Open a connection to the bus.  */
1149   connection = xd_initialize (bus);
1150
1151   /* Non blocking read of the next available message.  */
1152   dbus_connection_read_write (connection, 0);
1153   dmessage = dbus_connection_pop_message (connection);
1154
1155   /* Return if there is no queued message.  */
1156   if (dmessage == NULL)
1157     return Qnil;
1158
1159   /* Collect the parameters.  */
1160   args = Qnil;
1161   GCPRO1 (args);
1162
1163   /* Loop over the resulting parameters.  Construct a list.  */
1164   if (dbus_message_iter_init (dmessage, &iter))
1165     {
1166       while ((dtype = dbus_message_iter_get_arg_type (&iter))
1167              != DBUS_TYPE_INVALID)
1168         {
1169           args = Fcons (xd_retrieve_arg (dtype, &iter), args);
1170           dbus_message_iter_next (&iter);
1171         }
1172       /* The arguments are stored in reverse order.  Reorder them.  */
1173       args = Fnreverse (args);
1174     }
1175
1176   /* Read message type, unique name, object path, interface and member
1177      from the message.  */
1178   mtype =            dbus_message_get_type (dmessage);
1179   strcpy (uname,     dbus_message_get_sender (dmessage));
1180   strcpy (path,      dbus_message_get_path (dmessage));
1181   strcpy (interface, dbus_message_get_interface (dmessage));
1182   strcpy (member,    dbus_message_get_member (dmessage));
1183
1184   XD_DEBUG_MESSAGE ("Event received: %d %s %s %s %s %s",
1185                     mtype, uname, path, interface, member,
1186                     SDATA (format2 ("%s", args, Qnil)));
1187
1188   /* Search for a registered function of the message.  */
1189   key = list3 (bus, build_string (interface), build_string (member));
1190   value = Fgethash (key, Vdbus_registered_functions_table, Qnil);
1191
1192   /* Loop over the registered functions.  Construct an event.  */
1193   while (!NILP (value))
1194     {
1195       key = CAR_SAFE (value);
1196       /* key has the structure (UNAME SERVICE PATH HANDLER).  */
1197       if (((uname == NULL)
1198            || (NILP (CAR_SAFE (key)))
1199            || (strcmp (uname, SDATA (CAR_SAFE (key))) == 0))
1200           && ((path == NULL)
1201               || (NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1202               || (strcmp (path, SDATA (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1203                   == 0))
1204           && (!NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))))))
1205         {
1206           EVENT_INIT (event);
1207           event.kind = DBUS_EVENT;
1208           event.frame_or_window = Qnil;
1209           event.arg = Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))),
1210                              args);
1211
1212           /* Add uname, path, interface and member to the event.  */
1213           event.arg = Fcons ((member == NULL ? Qnil : build_string (member)),
1214                              event.arg);
1215           event.arg = Fcons ((interface == NULL
1216                               ? Qnil : build_string (interface)),
1217                              event.arg);
1218           event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
1219                              event.arg);
1220           event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
1221                              event.arg);
1222
1223           /* Add the message serial if needed, or nil.  */
1224           event.arg = Fcons ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL
1225                               ? make_number (dbus_message_get_serial (dmessage))
1226                               : Qnil),
1227                              event.arg);
1228
1229           /* Add the bus symbol to the event.  */
1230           event.arg = Fcons (bus, event.arg);
1231
1232           /* Store it into the input event queue.  */
1233           kbd_buffer_store_event (&event);
1234         }
1235      value = CDR_SAFE (value);
1236     }
1237
1238   /* Cleanup.  */
1239   dbus_message_unref (dmessage);
1240   RETURN_UNGCPRO (Qnil);
1241 }
1242
1243 /* Read queued incoming messages from the system and session buses.  */
1244 void
1245 xd_read_queued_messages ()
1246 {
1247
1248   /* Vdbus_registered_functions_table will be initialized as hash
1249      table in dbus.el.  When this package isn't loaded yet, it doesn't
1250      make sense to handle D-Bus messages.  Furthermore, we ignore all
1251      Lisp errors during the call.  */
1252   if (HASH_TABLE_P (Vdbus_registered_functions_table))
1253     {
1254       internal_condition_case_1 (xd_read_message, QCdbus_system_bus,
1255                                  Qerror, Fidentity);
1256       internal_condition_case_1 (xd_read_message, QCdbus_session_bus,
1257                                  Qerror, Fidentity);
1258     }
1259 }
1260
1261 DEFUN ("dbus-register-signal", Fdbus_register_signal, Sdbus_register_signal,
1262        6, 6, 0,
1263        doc: /* Register for signal SIGNAL on the D-Bus BUS.
1264
1265 BUS is either the symbol `:system' or the symbol `:session'.
1266
1267 SERVICE is the D-Bus service name used by the sending D-Bus object.
1268 It can be either a known name or the unique name of the D-Bus object
1269 sending the signal.  When SERVICE is nil, related signals from all
1270 D-Bus objects shall be accepted.
1271
1272 PATH is the D-Bus object path SERVICE is registered.  It can also be
1273 nil if the path name of incoming signals shall not be checked.
1274
1275 INTERFACE is an interface offered by SERVICE.  It must provide SIGNAL.
1276 HANDLER is a Lisp function to be called when the signal is received.
1277 It must accept as arguments the values SIGNAL is sending.  INTERFACE,
1278 SIGNAL and HANDLER must not be nil.  Example:
1279
1280 \(defun my-signal-handler (device)
1281   (message "Device %s added" device))
1282
1283 \(dbus-register-signal
1284   :system "org.freedesktop.Hal" "/org/freedesktop/Hal/Manager"
1285   "org.freedesktop.Hal.Manager" "DeviceAdded" 'my-signal-handler)
1286
1287   => ((:system "org.freedesktop.Hal.Manager" "DeviceAdded")
1288       ("org.freedesktop.Hal" "/org/freedesktop/Hal/Manager" my-signal-handler))
1289
1290 `dbus-register-signal' returns an object, which can be used in
1291 `dbus-unregister-object' for removing the registration.  */)
1292      (bus, service, path, interface, signal, handler)
1293      Lisp_Object bus, service, path, interface, signal, handler;
1294 {
1295   Lisp_Object uname, key, key1, value;
1296   DBusConnection *connection;
1297   char rule[DBUS_MAXIMUM_MATCH_RULE_LENGTH];
1298   DBusError derror;
1299
1300   /* Check parameters.  */
1301   CHECK_SYMBOL (bus);
1302   if (!NILP (service)) CHECK_STRING (service);
1303   if (!NILP (path)) CHECK_STRING (path);
1304   CHECK_STRING (interface);
1305   CHECK_STRING (signal);
1306   if (!FUNCTIONP (handler))
1307     wrong_type_argument (intern ("functionp"), handler);
1308
1309   /* Retrieve unique name of service.  If service is a known name, we
1310      will register for the corresponding unique name, if any.  Signals
1311      are sent always with the unique name as sender.  Note: the unique
1312      name of "org.freedesktop.DBus" is that string itself.  */
1313   if ((STRINGP (service))
1314       && (SBYTES (service) > 0)
1315       && (strcmp (SDATA (service), DBUS_SERVICE_DBUS) != 0)
1316       && (strncmp (SDATA (service), ":", 1) != 0))
1317     {
1318       uname = call2 (intern ("dbus-get-name-owner"), bus, service);
1319       /* When there is no unique name, we mark it with an empty
1320          string.  */
1321       if (NILP (uname))
1322         uname = build_string ("");
1323     }
1324   else
1325     uname = service;
1326
1327   /* Create a matching rule if the unique name exists (when no
1328      wildcard).  */
1329   if (NILP (uname) || (SBYTES (uname) > 0))
1330     {
1331       /* Open a connection to the bus.  */
1332       connection = xd_initialize (bus);
1333
1334       /* Create a rule to receive related signals.  */
1335       sprintf (rule,
1336                "type='signal',interface='%s',member='%s'",
1337                SDATA (interface),
1338                SDATA (signal));
1339
1340       /* Add unique name and path to the rule if they are non-nil.  */
1341       if (!NILP (uname))
1342         sprintf (rule, "%s,sender='%s'", rule, SDATA (uname));
1343
1344       if (!NILP (path))
1345         sprintf (rule, "%s,path='%s'", rule, SDATA (path));
1346
1347       /* Add the rule to the bus.  */
1348       dbus_error_init (&derror);
1349       dbus_bus_add_match (connection, rule, &derror);
1350       if (dbus_error_is_set (&derror))
1351         XD_ERROR (derror);
1352
1353       XD_DEBUG_MESSAGE ("Matching rule \"%s\" created", rule);
1354     }
1355
1356   /* Create a hash table entry.  */
1357   key = list3 (bus, interface, signal);
1358   key1 = list4 (uname, service, path, handler);
1359   value = Fgethash (key, Vdbus_registered_functions_table, Qnil);
1360
1361   if (NILP (Fmember (key1, value)))
1362     Fputhash (key, Fcons (key1, value), Vdbus_registered_functions_table);
1363
1364   /* Return object.  */
1365   return list2 (key, list3 (service, path, handler));
1366 }
1367
1368 DEFUN ("dbus-register-method", Fdbus_register_method, Sdbus_register_method,
1369        6, 6, 0,
1370        doc: /* Register for method METHOD on the D-Bus BUS.
1371
1372 BUS is either the symbol `:system' or the symbol `:session'.
1373
1374 SERVICE is the D-Bus service name of the D-Bus object METHOD is
1375 registered for.  It must be a known name.
1376
1377 PATH is the D-Bus object path SERVICE is registered.  INTERFACE is the
1378 interface offered by SERVICE.  It must provide METHOD.  HANDLER is a
1379 Lisp function to be called when a method call is received.  It must
1380 accept the input arguments of METHOD.  The return value of HANDLER is
1381 used for composing the returning D-Bus message.  */)
1382      (bus, service, path, interface, method, handler)
1383      Lisp_Object bus, service, path, interface, method, handler;
1384 {
1385   Lisp_Object key, key1, value;
1386   DBusConnection *connection;
1387   int result;
1388   DBusError derror;
1389
1390   /* Check parameters.  */
1391   CHECK_SYMBOL (bus);
1392   CHECK_STRING (service);
1393   CHECK_STRING (path);
1394   CHECK_STRING (interface);
1395   CHECK_STRING (method);
1396   if (!FUNCTIONP (handler))
1397     wrong_type_argument (intern ("functionp"), handler);
1398   /* TODO: We must check for a valid service name, otherwise there is
1399      a segmentation fault.  */
1400
1401   /* Open a connection to the bus.  */
1402   connection = xd_initialize (bus);
1403
1404   /* Request the known name from the bus.  We can ignore the result,
1405      it is set to -1 if there is an error - kind of redundancy.  */
1406   dbus_error_init (&derror);
1407   result = dbus_bus_request_name (connection, SDATA (service), 0, &derror);
1408   if (dbus_error_is_set (&derror))
1409     XD_ERROR (derror);
1410
1411   /* Create a hash table entry.  */
1412   key = list3 (bus, interface, method);
1413   key1 = list4 (Qnil, service, path, handler);
1414   value = Fgethash (key, Vdbus_registered_functions_table, Qnil);
1415
1416   /* We use nil for the unique name, because the method might be
1417      called from everybody.  */
1418   if (NILP (Fmember (key1, value)))
1419     Fputhash (key, Fcons (key1, value), Vdbus_registered_functions_table);
1420
1421   /* Return object.  */
1422   return list2 (key, list3 (service, path, handler));
1423 }
1424
1425 \f
1426 void
1427 syms_of_dbusbind ()
1428 {
1429
1430   Qdbus_get_unique_name = intern ("dbus-get-unique-name");
1431   staticpro (&Qdbus_get_unique_name);
1432   defsubr (&Sdbus_get_unique_name);
1433
1434   Qdbus_call_method = intern ("dbus-call-method");
1435   staticpro (&Qdbus_call_method);
1436   defsubr (&Sdbus_call_method);
1437
1438   Qdbus_method_return_internal = intern ("dbus-method-return-internal");
1439   staticpro (&Qdbus_method_return_internal);
1440   defsubr (&Sdbus_method_return_internal);
1441
1442   Qdbus_send_signal = intern ("dbus-send-signal");
1443   staticpro (&Qdbus_send_signal);
1444   defsubr (&Sdbus_send_signal);
1445
1446   Qdbus_register_signal = intern ("dbus-register-signal");
1447   staticpro (&Qdbus_register_signal);
1448   defsubr (&Sdbus_register_signal);
1449
1450   Qdbus_register_method = intern ("dbus-register-method");
1451   staticpro (&Qdbus_register_method);
1452   defsubr (&Sdbus_register_method);
1453
1454   Qdbus_error = intern ("dbus-error");
1455   staticpro (&Qdbus_error);
1456   Fput (Qdbus_error, Qerror_conditions,
1457         list2 (Qdbus_error, Qerror));
1458   Fput (Qdbus_error, Qerror_message,
1459         build_string ("D-Bus error"));
1460
1461   QCdbus_system_bus = intern (":system");
1462   staticpro (&QCdbus_system_bus);
1463
1464   QCdbus_session_bus = intern (":session");
1465   staticpro (&QCdbus_session_bus);
1466
1467   QCdbus_type_byte = intern (":byte");
1468   staticpro (&QCdbus_type_byte);
1469
1470   QCdbus_type_boolean = intern (":boolean");
1471   staticpro (&QCdbus_type_boolean);
1472
1473   QCdbus_type_int16 = intern (":int16");
1474   staticpro (&QCdbus_type_int16);
1475
1476   QCdbus_type_uint16 = intern (":uint16");
1477   staticpro (&QCdbus_type_uint16);
1478
1479   QCdbus_type_int32 = intern (":int32");
1480   staticpro (&QCdbus_type_int32);
1481
1482   QCdbus_type_uint32 = intern (":uint32");
1483   staticpro (&QCdbus_type_uint32);
1484
1485   QCdbus_type_int64 = intern (":int64");
1486   staticpro (&QCdbus_type_int64);
1487
1488   QCdbus_type_uint64 = intern (":uint64");
1489   staticpro (&QCdbus_type_uint64);
1490
1491   QCdbus_type_double = intern (":double");
1492   staticpro (&QCdbus_type_double);
1493
1494   QCdbus_type_string = intern (":string");
1495   staticpro (&QCdbus_type_string);
1496
1497   QCdbus_type_object_path = intern (":object-path");
1498   staticpro (&QCdbus_type_object_path);
1499
1500   QCdbus_type_signature = intern (":signature");
1501   staticpro (&QCdbus_type_signature);
1502
1503   QCdbus_type_array = intern (":array");
1504   staticpro (&QCdbus_type_array);
1505
1506   QCdbus_type_variant = intern (":variant");
1507   staticpro (&QCdbus_type_variant);
1508
1509   QCdbus_type_struct = intern (":struct");
1510   staticpro (&QCdbus_type_struct);
1511
1512   QCdbus_type_dict_entry = intern (":dict-entry");
1513   staticpro (&QCdbus_type_dict_entry);
1514
1515   DEFVAR_LISP ("dbus-registered-functions-table",
1516                &Vdbus_registered_functions_table,
1517     doc: /* Hash table of registered functions for D-Bus.
1518 The key in the hash table is the list (BUS INTERFACE MEMBER).  BUS is
1519 either the symbol `:system' or the symbol `:session'.  INTERFACE is a
1520 string which denotes a D-Bus interface, and MEMBER, also a string, is
1521 either a method or a signal INTERFACE is offering.  All arguments but
1522 BUS must not be nil.
1523
1524 The value in the hash table is a list of quadruple lists
1525 \((UNAME SERVICE PATH HANDLER) (UNAME SERVICE PATH HANDLER) ...).
1526 SERVICE is the service name as registered, UNAME is the corresponding
1527 unique name.  PATH is the object path of the sending object.  All of
1528 them can be nil, which means a wildcard then.  HANDLER is the function
1529 to be called when a D-Bus message, which matches the key criteria,
1530 arrives.  */);
1531   /* We initialize Vdbus_registered_functions_table in dbus.el,
1532      because we need to define a hash table function first.  */
1533   Vdbus_registered_functions_table = Qnil;
1534
1535   DEFVAR_LISP ("dbus-debug", &Vdbus_debug,
1536     doc: /* If non-nil, debug messages of D-Bus bindings are raised.  */);
1537 #ifdef DBUS_DEBUG
1538   Vdbus_debug = Qt;
1539 #else
1540   Vdbus_debug = Qnil;
1541 #endif
1542
1543   Fprovide (intern ("dbusbind"), Qnil);
1544
1545 }
1546
1547 #endif /* HAVE_DBUS */
1548
1549 /* arch-tag: 0e828477-b571-4fe4-b559-5c9211bc14b8
1550    (do not change this comment) */