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         dbus_uint32_t val;
 598         dbus_message_iter_get_basic (iter, &val);
 599         XD_DEBUG_MESSAGE ("%c %d", dtype, val);
 600         return make_fixnum_or_float (val);
 601       }
 602
 603     case DBUS_TYPE_INT64:
 604     case DBUS_TYPE_UINT64:
 605       {
 606         dbus_uint64_t val;
 607         dbus_message_iter_get_basic (iter, &val);
 608         XD_DEBUG_MESSAGE ("%c %d", dtype, (int) val);
 609         return make_fixnum_or_float (val);
 610       }
 611
 612     case DBUS_TYPE_DOUBLE:
 613       {
 614         double val;
 615         dbus_message_iter_get_basic (iter, &val);
 616         XD_DEBUG_MESSAGE ("%c %f", dtype, val);
 617         return make_float (val);
 618       }
 619
 620     case DBUS_TYPE_STRING:
 621     case DBUS_TYPE_OBJECT_PATH:
 622     case DBUS_TYPE_SIGNATURE:
 623       {
 624         char *val;
 625         dbus_message_iter_get_basic (iter, &val);
 626         XD_DEBUG_MESSAGE ("%c %s", dtype, val);
 627         return build_string (val);
 628       }
 629
 630     case DBUS_TYPE_ARRAY:
 631     case DBUS_TYPE_VARIANT:
 632     case DBUS_TYPE_STRUCT:
 633     case DBUS_TYPE_DICT_ENTRY:
 634       {
 635         Lisp_Object result;
 636         struct gcpro gcpro1;
 637         result = Qnil;
 638         GCPRO1 (result);
 639         DBusMessageIter subiter;
 640         int subtype;
 641         dbus_message_iter_recurse (iter, &subiter);
 642         while ((subtype = dbus_message_iter_get_arg_type (&subiter))
 643                != DBUS_TYPE_INVALID)
 644           {
 645             result = Fcons (xd_retrieve_arg (subtype, &subiter), result);
 646             dbus_message_iter_next (&subiter);
 647           }
 648         XD_DEBUG_MESSAGE ("%c %s", dtype, SDATA (format2 ("%s", result, Qnil)));
 649         RETURN_UNGCPRO (Fnreverse (result));
 650       }
 651
 652     default:
 653       XD_DEBUG_MESSAGE ("DBusType '%c' not supported", dtype);
 654       return Qnil;
 655     }
 656 }
 657
 658 /* Initialize D-Bus connection.  BUS is a Lisp symbol, either :system
 659    or :session.  It tells which D-Bus to be initialized.  */
 660 DBusConnection *
 661 xd_initialize (bus)
 662      Lisp_Object bus;
 663 {
 664   DBusConnection *connection;
 665   DBusError derror;
 666
 667   /* Parameter check.  */
 668   CHECK_SYMBOL (bus);
 669   if (!((EQ (bus, QCdbus_system_bus)) || (EQ (bus, QCdbus_session_bus))))
 670     xsignal2 (Qdbus_error, build_string ("Wrong bus name"), bus);
 671
 672   /* Open a connection to the bus.  */
 673   dbus_error_init (&derror);
 674
 675   if (EQ (bus, QCdbus_system_bus))
 676     connection = dbus_bus_get (DBUS_BUS_SYSTEM, &derror);
 677   else
 678     connection = dbus_bus_get (DBUS_BUS_SESSION, &derror);
 679
 680   if (dbus_error_is_set (&derror))
 681     XD_ERROR (derror);
 682
 683   if (connection == NULL)
 684     xsignal2 (Qdbus_error, build_string ("No connection"), bus);
 685
 686   /* Return the result.  */
 687   return connection;
 688 }
 689
 690 DEFUN ("dbus-get-unique-name", Fdbus_get_unique_name, Sdbus_get_unique_name,
 691        1, 1, 0,
 692        doc: /* Return the unique name of Emacs registered at D-Bus BUS.  */)
 693      (bus)
 694      Lisp_Object bus;
 695 {
 696   DBusConnection *connection;
 697   char name[DBUS_MAXIMUM_NAME_LENGTH];
 698
 699   /* Check parameters.  */
 700   CHECK_SYMBOL (bus);
 701
 702   /* Open a connection to the bus.  */
 703   connection = xd_initialize (bus);
 704
 705   /* Request the name.  */
 706   strcpy (name, dbus_bus_get_unique_name (connection));
 707   if (name == NULL)
 708     xsignal1 (Qdbus_error, build_string ("No unique name available"));
 709
 710   /* Return.  */
 711   return build_string (name);
 712 }
 713
 714 DEFUN ("dbus-call-method", Fdbus_call_method, Sdbus_call_method, 5, MANY, 0,
 715        doc: /* Call METHOD on the D-Bus BUS.
 716
 717 BUS is either the symbol `:system' or the symbol `:session'.
 718
 719 SERVICE is the D-Bus service name to be used.  PATH is the D-Bus
 720 object path SERVICE is registered at.  INTERFACE is an interface
 721 offered by SERVICE.  It must provide METHOD.
 722
 723 All other arguments ARGS are passed to METHOD as arguments.  They are
 724 converted into D-Bus types via the following rules:
 725
 726   t and nil => DBUS_TYPE_BOOLEAN
 727   number    => DBUS_TYPE_UINT32
 728   integer   => DBUS_TYPE_INT32
 729   float     => DBUS_TYPE_DOUBLE
 730   string    => DBUS_TYPE_STRING
 731   list      => DBUS_TYPE_ARRAY
 732
 733 All arguments can be preceded by a type symbol.  For details about
 734 type symbols, see Info node `(dbus)Type Conversion'.
 735
 736 `dbus-call-method' returns the resulting values of METHOD as a list of
 737 Lisp objects.  The type conversion happens the other direction as for
 738 input arguments.  It follows the mapping rules:
 739
 740   DBUS_TYPE_BOOLEAN     => t or nil
 741   DBUS_TYPE_BYTE        => number
 742   DBUS_TYPE_UINT16      => number
 743   DBUS_TYPE_INT16       => integer
 744   DBUS_TYPE_UINT32      => number or float
 745   DBUS_TYPE_INT32       => integer or float
 746   DBUS_TYPE_UINT64      => number or float
 747   DBUS_TYPE_INT64       => integer or float
 748   DBUS_TYPE_DOUBLE      => float
 749   DBUS_TYPE_STRING      => string
 750   DBUS_TYPE_OBJECT_PATH => string
 751   DBUS_TYPE_SIGNATURE   => string
 752   DBUS_TYPE_ARRAY       => list
 753   DBUS_TYPE_VARIANT     => list
 754   DBUS_TYPE_STRUCT      => list
 755   DBUS_TYPE_DICT_ENTRY  => list
 756
 757 Example:
 758
 759 \(dbus-call-method
 760   :session "org.gnome.seahorse" "/org/gnome/seahorse/keys/openpgp"
 761   "org.gnome.seahorse.Keys" "GetKeyField"
 762   "openpgp:657984B8C7A966DD" "simple-name")
 763
 764   => (t ("Philip R. Zimmermann"))
 765
 766 If the result of the METHOD call is just one value, the converted Lisp
 767 object is returned instead of a list containing this single Lisp object.
 768
 769 \(dbus-call-method
 770   :system "org.freedesktop.Hal" "/org/freedesktop/Hal/devices/computer"
 771   "org.freedesktop.Hal.Device" "GetPropertyString"
 772   "system.kernel.machine")
 773
 774   => "i686"
 775
 776 usage: (dbus-call-method BUS SERVICE PATH INTERFACE METHOD &rest ARGS)  */)
 777      (nargs, args)
 778      int nargs;
 779      register Lisp_Object *args;
 780 {
 781   Lisp_Object bus, service, path, interface, method;
 782   Lisp_Object result;
 783   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
 784   DBusConnection *connection;
 785   DBusMessage *dmessage;
 786   DBusMessage *reply;
 787   DBusMessageIter iter;
 788   DBusError derror;
 789   unsigned int dtype;
 790   int i;
 791   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
 792
 793   /* Check parameters.  */
 794   bus = args[0];
 795   service = args[1];
 796   path = args[2];
 797   interface = args[3];
 798   method = args[4];
 799
 800   CHECK_SYMBOL (bus);
 801   CHECK_STRING (service);
 802   CHECK_STRING (path);
 803   CHECK_STRING (interface);
 804   CHECK_STRING (method);
 805   GCPRO5 (bus, service, path, interface, method);
 806
 807   XD_DEBUG_MESSAGE ("%s %s %s %s",
 808                     SDATA (service),
 809                     SDATA (path),
 810                     SDATA (interface),
 811                     SDATA (method));
 812
 813   /* Open a connection to the bus.  */
 814   connection = xd_initialize (bus);
 815
 816   /* Create the message.  */
 817   dmessage = dbus_message_new_method_call (SDATA (service),
 818                                            SDATA (path),
 819                                            SDATA (interface),
 820                                            SDATA (method));
 821   if (dmessage == NULL)
 822     {
 823       UNGCPRO;
 824       xsignal1 (Qdbus_error, build_string ("Unable to create a new message"));
 825     }
 826
 827   UNGCPRO;
 828
 829   /* Initialize parameter list of message.  */
 830   dbus_message_iter_init_append (dmessage, &iter);
 831
 832   /* Append parameters to the message.  */
 833   for (i = 5; i < nargs; ++i)
 834     {
 835       dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
 836       if (XD_DBUS_TYPE_P (args[i]))
 837         {
 838           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
 839           XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
 840           XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-4,
 841                             SDATA (format2 ("%s", args[i], Qnil)),
 842                             SDATA (format2 ("%s", args[i+1], Qnil)));
 843           ++i;
 844         }
 845       else
 846         {
 847           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
 848           XD_DEBUG_MESSAGE ("Parameter%d %s", i-4,
 849                             SDATA (format2 ("%s", args[i], Qnil)));
 850         }
 851
 852       /* Check for valid signature.  We use DBUS_TYPE_INVALID as
 853          indication that there is no parent type.  */
 854       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
 855
 856       xd_append_arg (dtype, args[i], &iter);
 857     }
 858
 859   /* Send the message.  */
 860   dbus_error_init (&derror);
 861   reply = dbus_connection_send_with_reply_and_block (connection,
 862                                                      dmessage,
 863                                                      -1,
 864                                                      &derror);
 865
 866   if (dbus_error_is_set (&derror))
 867     XD_ERROR (derror);
 868
 869   if (reply == NULL)
 870     xsignal1 (Qdbus_error, build_string ("No reply"));
 871
 872   XD_DEBUG_MESSAGE ("Message sent");
 873
 874   /* Collect the results.  */
 875   result = Qnil;
 876   GCPRO1 (result);
 877
 878   if (dbus_message_iter_init (reply, &iter))
 879     {
 880       /* Loop over the parameters of the D-Bus reply message.  Construct a
 881          Lisp list, which is returned by `dbus-call-method'.  */
 882       while ((dtype = dbus_message_iter_get_arg_type (&iter))
 883              != DBUS_TYPE_INVALID)
 884         {
 885           result = Fcons (xd_retrieve_arg (dtype, &iter), result);
 886           dbus_message_iter_next (&iter);
 887         }
 888     }
 889   else
 890     {
 891       /* No arguments: just return nil.  */
 892     }
 893
 894   /* Cleanup.  */
 895   dbus_message_unref (dmessage);
 896   dbus_message_unref (reply);
 897
 898   /* Return the result.  If there is only one single Lisp object,
 899      return it as-it-is, otherwise return the reversed list.  */
 900   if (XUINT (Flength (result)) == 1)
 901     RETURN_UNGCPRO (CAR_SAFE (result));
 902   else
 903     RETURN_UNGCPRO (Fnreverse (result));
 904 }
 905
 906 DEFUN ("dbus-method-return-internal", Fdbus_method_return_internal,
 907        Sdbus_method_return_internal,
 908        3, MANY, 0,
 909        doc: /* Return for message SERIAL on the D-Bus BUS.
 910 This is an internal function, it shall not be used outside dbus.el.
 911
 912 usage: (dbus-method-return-internal BUS SERIAL SERVICE &rest ARGS)  */)
 913      (nargs, args)
 914      int nargs;
 915      register Lisp_Object *args;
 916 {
 917   Lisp_Object bus, serial, service;
 918   struct gcpro gcpro1, gcpro2, gcpro3;
 919   DBusConnection *connection;
 920   DBusMessage *dmessage;
 921   DBusMessageIter iter;
 922   unsigned int dtype;
 923   int i;
 924   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
 925
 926   /* Check parameters.  */
 927   bus = args[0];
 928   serial = args[1];
 929   service = args[2];
 930
 931   CHECK_SYMBOL (bus);
 932   CHECK_NUMBER (serial);
 933   CHECK_STRING (service);
 934   GCPRO3 (bus, serial, service);
 935
 936   XD_DEBUG_MESSAGE ("%d %s ", XUINT (serial), SDATA (service));
 937
 938   /* Open a connection to the bus.  */
 939   connection = xd_initialize (bus);
 940
 941   /* Create the message.  */
 942   dmessage = dbus_message_new (DBUS_MESSAGE_TYPE_METHOD_RETURN);
 943   if ((dmessage == NULL)
 944       || (!dbus_message_set_reply_serial (dmessage, XUINT (serial)))
 945       || (!dbus_message_set_destination (dmessage, SDATA (service))))
 946     {
 947       UNGCPRO;
 948       xsignal1 (Qdbus_error,
 949                 build_string ("Unable to create a return message"));
 950     }
 951
 952   UNGCPRO;
 953
 954   /* Initialize parameter list of message.  */
 955   dbus_message_iter_init_append (dmessage, &iter);
 956
 957   /* Append parameters to the message.  */
 958   for (i = 3; i < nargs; ++i)
 959     {
 960       dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
 961       if (XD_DBUS_TYPE_P (args[i]))
 962         {
 963           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
 964           XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
 965           XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-2,
 966                             SDATA (format2 ("%s", args[i], Qnil)),
 967                             SDATA (format2 ("%s", args[i+1], Qnil)));
 968           ++i;
 969         }
 970       else
 971         {
 972           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
 973           XD_DEBUG_MESSAGE ("Parameter%d %s", i-2,
 974                             SDATA (format2 ("%s", args[i], Qnil)));
 975         }
 976
 977       /* Check for valid signature.  We use DBUS_TYPE_INVALID as
 978          indication that there is no parent type.  */
 979       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
 980
 981       xd_append_arg (dtype, args[i], &iter);
 982     }
 983
 984   /* Send the message.  The message is just added to the outgoing
 985      message queue.  */
 986   if (!dbus_connection_send (connection, dmessage, NULL))
 987     xsignal1 (Qdbus_error, build_string ("Cannot send message"));
 988
 989   /* Flush connection to ensure the message is handled.  */
 990   dbus_connection_flush (connection);
 991
 992   XD_DEBUG_MESSAGE ("Message sent");
 993
 994   /* Cleanup.  */
 995   dbus_message_unref (dmessage);
 996
 997   /* Return.  */
 998   return Qt;
 999 }
1000
1001 DEFUN ("dbus-send-signal", Fdbus_send_signal, Sdbus_send_signal, 5, MANY, 0,
1002        doc: /* Send signal SIGNAL on the D-Bus BUS.
1003
1004 BUS is either the symbol `:system' or the symbol `:session'.
1005
1006 SERVICE is the D-Bus service name SIGNAL is sent from.  PATH is the
1007 D-Bus object path SERVICE is registered at.  INTERFACE is an interface
1008 offered by SERVICE.  It must provide signal SIGNAL.
1009
1010 All other arguments ARGS are passed to SIGNAL as arguments.  They are
1011 converted into D-Bus types via the following rules:
1012
1013   t and nil => DBUS_TYPE_BOOLEAN
1014   number    => DBUS_TYPE_UINT32
1015   integer   => DBUS_TYPE_INT32
1016   float     => DBUS_TYPE_DOUBLE
1017   string    => DBUS_TYPE_STRING
1018   list      => DBUS_TYPE_ARRAY
1019
1020 All arguments can be preceded by a type symbol.  For details about
1021 type symbols, see Info node `(dbus)Type Conversion'.
1022
1023 Example:
1024
1025 \(dbus-send-signal
1026   :session "org.gnu.Emacs" "/org/gnu/Emacs"
1027   "org.gnu.Emacs.FileManager" "FileModified" "/home/albinus/.emacs")
1028
1029 usage: (dbus-send-signal BUS SERVICE PATH INTERFACE SIGNAL &rest ARGS)  */)
1030      (nargs, args)
1031      int nargs;
1032      register Lisp_Object *args;
1033 {
1034   Lisp_Object bus, service, path, interface, signal;
1035   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
1036   DBusConnection *connection;
1037   DBusMessage *dmessage;
1038   DBusMessageIter iter;
1039   unsigned int dtype;
1040   int i;
1041   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1042
1043   /* Check parameters.  */
1044   bus = args[0];
1045   service = args[1];
1046   path = args[2];
1047   interface = args[3];
1048   signal = args[4];
1049
1050   CHECK_SYMBOL (bus);
1051   CHECK_STRING (service);
1052   CHECK_STRING (path);
1053   CHECK_STRING (interface);
1054   CHECK_STRING (signal);
1055   GCPRO5 (bus, service, path, interface, signal);
1056
1057   XD_DEBUG_MESSAGE ("%s %s %s %s",
1058                     SDATA (service),
1059                     SDATA (path),
1060                     SDATA (interface),
1061                     SDATA (signal));
1062
1063   /* Open a connection to the bus.  */
1064   connection = xd_initialize (bus);
1065
1066   /* Create the message.  */
1067   dmessage = dbus_message_new_signal (SDATA (path),
1068                                       SDATA (interface),
1069                                       SDATA (signal));
1070   if (dmessage == NULL)
1071     {
1072       UNGCPRO;
1073       xsignal1 (Qdbus_error, build_string ("Unable to create a new message"));
1074     }
1075
1076   UNGCPRO;
1077
1078   /* Initialize parameter list of message.  */
1079   dbus_message_iter_init_append (dmessage, &iter);
1080
1081   /* Append parameters to the message.  */
1082   for (i = 5; i < nargs; ++i)
1083     {
1084       dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1085       if (XD_DBUS_TYPE_P (args[i]))
1086         {
1087           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1088           XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1089           XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-4,
1090                             SDATA (format2 ("%s", args[i], Qnil)),
1091                             SDATA (format2 ("%s", args[i+1], Qnil)));
1092           ++i;
1093         }
1094       else
1095         {
1096           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1097           XD_DEBUG_MESSAGE ("Parameter%d %s", i-4,
1098                             SDATA (format2 ("%s", args[i], Qnil)));
1099         }
1100
1101       /* Check for valid signature.  We use DBUS_TYPE_INVALID as
1102          indication that there is no parent type.  */
1103       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1104
1105       xd_append_arg (dtype, args[i], &iter);
1106     }
1107
1108   /* Send the message.  The message is just added to the outgoing
1109      message queue.  */
1110   if (!dbus_connection_send (connection, dmessage, NULL))
1111     xsignal1 (Qdbus_error, build_string ("Cannot send message"));
1112
1113   /* Flush connection to ensure the message is handled.  */
1114   dbus_connection_flush (connection);
1115
1116   XD_DEBUG_MESSAGE ("Signal sent");
1117
1118   /* Cleanup.  */
1119   dbus_message_unref (dmessage);
1120
1121   /* Return.  */
1122   return Qt;
1123 }
1124
1125 /* Read queued incoming message of the D-Bus BUS.  BUS is a Lisp
1126    symbol, either :system or :session.  */
1127 Lisp_Object
1128 xd_read_message (bus)
1129      Lisp_Object bus;
1130 {
1131   Lisp_Object args, key, value;
1132   struct gcpro gcpro1;
1133   struct input_event event;
1134   DBusConnection *connection;
1135   DBusMessage *dmessage;
1136   DBusMessageIter iter;
1137   unsigned int dtype;
1138   int mtype;
1139   char uname[DBUS_MAXIMUM_NAME_LENGTH];
1140   char path[DBUS_MAXIMUM_MATCH_RULE_LENGTH]; /* Unlimited in D-Bus spec.  */
1141   char interface[DBUS_MAXIMUM_NAME_LENGTH];
1142   char member[DBUS_MAXIMUM_NAME_LENGTH];
1143
1144   /* Open a connection to the bus.  */
1145   connection = xd_initialize (bus);
1146
1147   /* Non blocking read of the next available message.  */
1148   dbus_connection_read_write (connection, 0);
1149   dmessage = dbus_connection_pop_message (connection);
1150
1151   /* Return if there is no queued message.  */
1152   if (dmessage == NULL)
1153     return Qnil;
1154
1155   /* Collect the parameters.  */
1156   args = Qnil;
1157   GCPRO1 (args);
1158
1159   /* Loop over the resulting parameters.  Construct a list.  */
1160   if (dbus_message_iter_init (dmessage, &iter))
1161     {
1162       while ((dtype = dbus_message_iter_get_arg_type (&iter))
1163              != DBUS_TYPE_INVALID)
1164         {
1165           args = Fcons (xd_retrieve_arg (dtype, &iter), args);
1166           dbus_message_iter_next (&iter);
1167         }
1168       /* The arguments are stored in reverse order.  Reorder them.  */
1169       args = Fnreverse (args);
1170     }
1171
1172   /* Read message type, unique name, object path, interface and member
1173      from the message.  */
1174   mtype =            dbus_message_get_type (dmessage);
1175   strcpy (uname,     dbus_message_get_sender (dmessage));
1176   strcpy (path,      dbus_message_get_path (dmessage));
1177   strcpy (interface, dbus_message_get_interface (dmessage));
1178   strcpy (member,    dbus_message_get_member (dmessage));
1179
1180   XD_DEBUG_MESSAGE ("Event received: %d %s %s %s %s %s",
1181                     mtype, uname, path, interface, member,
1182                     SDATA (format2 ("%s", args, Qnil)));
1183
1184   /* Search for a registered function of the message.  */
1185   key = list3 (bus, build_string (interface), build_string (member));
1186   value = Fgethash (key, Vdbus_registered_functions_table, Qnil);
1187
1188   /* Loop over the registered functions.  Construct an event.  */
1189   while (!NILP (value))
1190     {
1191       key = CAR_SAFE (value);
1192       /* key has the structure (UNAME SERVICE PATH HANDLER).  */
1193       if (((uname == NULL)
1194            || (NILP (CAR_SAFE (key)))
1195            || (strcmp (uname, SDATA (CAR_SAFE (key))) == 0))
1196           && ((path == NULL)
1197               || (NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1198               || (strcmp (path, SDATA (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1199                   == 0))
1200           && (!NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))))))
1201         {
1202           EVENT_INIT (event);
1203           event.kind = DBUS_EVENT;
1204           event.frame_or_window = Qnil;
1205           event.arg = Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))),
1206                              args);
1207
1208           /* Add uname, path, interface and member to the event.  */
1209           event.arg = Fcons ((member == NULL ? Qnil : build_string (member)),
1210                              event.arg);
1211           event.arg = Fcons ((interface == NULL
1212                               ? Qnil : build_string (interface)),
1213                              event.arg);
1214           event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
1215                              event.arg);
1216           event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
1217                              event.arg);
1218
1219           /* Add the message serial if needed, or nil.  */
1220           event.arg = Fcons ((mtype == DBUS_MESSAGE_TYPE_METHOD_CALL
1221                               ? make_number (dbus_message_get_serial (dmessage))
1222                               : Qnil),
1223                              event.arg);
1224
1225           /* Add the bus symbol to the event.  */
1226           event.arg = Fcons (bus, event.arg);
1227
1228           /* Store it into the input event queue.  */
1229           kbd_buffer_store_event (&event);
1230         }
1231      value = CDR_SAFE (value);
1232     }
1233
1234   /* Cleanup.  */
1235   dbus_message_unref (dmessage);
1236   RETURN_UNGCPRO (Qnil);
1237 }
1238
1239 /* Read queued incoming messages from the system and session buses.  */
1240 void
1241 xd_read_queued_messages ()
1242 {
1243
1244   /* Vdbus_registered_functions_table will be initialized as hash
1245      table in dbus.el.  When this package isn't loaded yet, it doesn't
1246      make sense to handle D-Bus messages.  Furthermore, we ignore all
1247      Lisp errors during the call.  */
1248   if (HASH_TABLE_P (Vdbus_registered_functions_table))
1249     {
1250       internal_condition_case_1 (xd_read_message, QCdbus_system_bus,
1251                                  Qerror, Fidentity);
1252       internal_condition_case_1 (xd_read_message, QCdbus_session_bus,
1253                                  Qerror, Fidentity);
1254     }
1255 }
1256
1257 DEFUN ("dbus-register-signal", Fdbus_register_signal, Sdbus_register_signal,
1258        6, 6, 0,
1259        doc: /* Register for signal SIGNAL on the D-Bus BUS.
1260
1261 BUS is either the symbol `:system' or the symbol `:session'.
1262
1263 SERVICE is the D-Bus service name used by the sending D-Bus object.
1264 It can be either a known name or the unique name of the D-Bus object
1265 sending the signal.  When SERVICE is nil, related signals from all
1266 D-Bus objects shall be accepted.
1267
1268 PATH is the D-Bus object path SERVICE is registered.  It can also be
1269 nil if the path name of incoming signals shall not be checked.
1270
1271 INTERFACE is an interface offered by SERVICE.  It must provide SIGNAL.
1272 HANDLER is a Lisp function to be called when the signal is received.
1273 It must accept as arguments the values SIGNAL is sending.  INTERFACE,
1274 SIGNAL and HANDLER must not be nil.  Example:
1275
1276 \(defun my-signal-handler (device)
1277   (message "Device %s added" device))
1278
1279 \(dbus-register-signal
1280   :system "org.freedesktop.Hal" "/org/freedesktop/Hal/Manager"
1281   "org.freedesktop.Hal.Manager" "DeviceAdded" 'my-signal-handler)
1282
1283   => ((:system "org.freedesktop.Hal.Manager" "DeviceAdded")
1284       ("org.freedesktop.Hal" "/org/freedesktop/Hal/Manager" my-signal-handler))
1285
1286 `dbus-register-signal' returns an object, which can be used in
1287 `dbus-unregister-object' for removing the registration.  */)
1288      (bus, service, path, interface, signal, handler)
1289      Lisp_Object bus, service, path, interface, signal, handler;
1290 {
1291   Lisp_Object uname, key, key1, value;
1292   DBusConnection *connection;
1293   char rule[DBUS_MAXIMUM_MATCH_RULE_LENGTH];
1294   DBusError derror;
1295
1296   /* Check parameters.  */
1297   CHECK_SYMBOL (bus);
1298   if (!NILP (service)) CHECK_STRING (service);
1299   if (!NILP (path)) CHECK_STRING (path);
1300   CHECK_STRING (interface);
1301   CHECK_STRING (signal);
1302   if (!FUNCTIONP (handler))
1303     wrong_type_argument (intern ("functionp"), handler);
1304
1305   /* Retrieve unique name of service.  If service is a known name, we
1306      will register for the corresponding unique name, if any.  Signals
1307      are sent always with the unique name as sender.  Note: the unique
1308      name of "org.freedesktop.DBus" is that string itself.  */
1309   if ((STRINGP (service))
1310       && (SBYTES (service) > 0)
1311       && (strcmp (SDATA (service), DBUS_SERVICE_DBUS) != 0)
1312       && (strncmp (SDATA (service), ":", 1) != 0))
1313     {
1314       uname = call2 (intern ("dbus-get-name-owner"), bus, service);
1315       /* When there is no unique name, we mark it with an empty
1316          string.  */
1317       if (NILP (uname))
1318         uname = build_string ("");
1319     }
1320   else
1321     uname = service;
1322
1323   /* Create a matching rule if the unique name exists (when no
1324      wildcard).  */
1325   if (NILP (uname) || (SBYTES (uname) > 0))
1326     {
1327       /* Open a connection to the bus.  */
1328       connection = xd_initialize (bus);
1329
1330       /* Create a rule to receive related signals.  */
1331       sprintf (rule,
1332                "type='signal',interface='%s',member='%s'",
1333                SDATA (interface),
1334                SDATA (signal));
1335
1336       /* Add unique name and path to the rule if they are non-nil.  */
1337       if (!NILP (uname))
1338         sprintf (rule, "%s,sender='%s'", rule, SDATA (uname));
1339
1340       if (!NILP (path))
1341         sprintf (rule, "%s,path='%s'", rule, SDATA (path));
1342
1343       /* Add the rule to the bus.  */
1344       dbus_error_init (&derror);
1345       dbus_bus_add_match (connection, rule, &derror);
1346       if (dbus_error_is_set (&derror))
1347         XD_ERROR (derror);
1348
1349       XD_DEBUG_MESSAGE ("Matching rule \"%s\" created", rule);
1350     }
1351
1352   /* Create a hash table entry.  */
1353   key = list3 (bus, interface, signal);
1354   key1 = list4 (uname, service, path, handler);
1355   value = Fgethash (key, Vdbus_registered_functions_table, Qnil);
1356
1357   if (NILP (Fmember (key1, value)))
1358     Fputhash (key, Fcons (key1, value), Vdbus_registered_functions_table);
1359
1360   /* Return object.  */
1361   return list2 (key, list3 (service, path, handler));
1362 }
1363
1364 DEFUN ("dbus-register-method", Fdbus_register_method, Sdbus_register_method,
1365        6, 6, 0,
1366        doc: /* Register for method METHOD on the D-Bus BUS.
1367
1368 BUS is either the symbol `:system' or the symbol `:session'.
1369
1370 SERVICE is the D-Bus service name of the D-Bus object METHOD is
1371 registered for.  It must be a known name.
1372
1373 PATH is the D-Bus object path SERVICE is registered.  INTERFACE is the
1374 interface offered by SERVICE.  It must provide METHOD.  HANDLER is a
1375 Lisp function to be called when a method call is received.  It must
1376 accept the input arguments of METHOD.  The return value of HANDLER is
1377 used for composing the returning D-Bus message.  */)
1378      (bus, service, path, interface, method, handler)
1379      Lisp_Object bus, service, path, interface, method, handler;
1380 {
1381   Lisp_Object key, key1, value;
1382   DBusConnection *connection;
1383   int result;
1384   DBusError derror;
1385
1386   /* Check parameters.  */
1387   CHECK_SYMBOL (bus);
1388   CHECK_STRING (service);
1389   CHECK_STRING (path);
1390   CHECK_STRING (interface);
1391   CHECK_STRING (method);
1392   if (!FUNCTIONP (handler))
1393     wrong_type_argument (intern ("functionp"), handler);
1394   /* TODO: We must check for a valid service name, otherwise there is
1395      a segmentation fault.  */
1396
1397   /* Open a connection to the bus.  */
1398   connection = xd_initialize (bus);
1399
1400   /* Request the known name from the bus.  We can ignore the result,
1401      it is set to -1 if there is an error - kind of redundancy.  */
1402   dbus_error_init (&derror);
1403   result = dbus_bus_request_name (connection, SDATA (service), 0, &derror);
1404   if (dbus_error_is_set (&derror))
1405     XD_ERROR (derror);
1406
1407   /* Create a hash table entry.  */
1408   key = list3 (bus, interface, method);
1409   key1 = list4 (Qnil, service, path, handler);
1410   value = Fgethash (key, Vdbus_registered_functions_table, Qnil);
1411
1412   /* We use nil for the unique name, because the method might be
1413      called from everybody.  */
1414   if (NILP (Fmember (key1, value)))
1415     Fputhash (key, Fcons (key1, value), Vdbus_registered_functions_table);
1416
1417   /* Return object.  */
1418   return list2 (key, list3 (service, path, handler));
1419 }
1420
1421 \f
1422 void
1423 syms_of_dbusbind ()
1424 {
1425
1426   Qdbus_get_unique_name = intern ("dbus-get-unique-name");
1427   staticpro (&Qdbus_get_unique_name);
1428   defsubr (&Sdbus_get_unique_name);
1429
1430   Qdbus_call_method = intern ("dbus-call-method");
1431   staticpro (&Qdbus_call_method);
1432   defsubr (&Sdbus_call_method);
1433
1434   Qdbus_method_return_internal = intern ("dbus-method-return-internal");
1435   staticpro (&Qdbus_method_return_internal);
1436   defsubr (&Sdbus_method_return_internal);
1437
1438   Qdbus_send_signal = intern ("dbus-send-signal");
1439   staticpro (&Qdbus_send_signal);
1440   defsubr (&Sdbus_send_signal);
1441
1442   Qdbus_register_signal = intern ("dbus-register-signal");
1443   staticpro (&Qdbus_register_signal);
1444   defsubr (&Sdbus_register_signal);
1445
1446   Qdbus_register_method = intern ("dbus-register-method");
1447   staticpro (&Qdbus_register_method);
1448   defsubr (&Sdbus_register_method);
1449
1450   Qdbus_error = intern ("dbus-error");
1451   staticpro (&Qdbus_error);
1452   Fput (Qdbus_error, Qerror_conditions,
1453         list2 (Qdbus_error, Qerror));
1454   Fput (Qdbus_error, Qerror_message,
1455         build_string ("D-Bus error"));
1456
1457   QCdbus_system_bus = intern (":system");
1458   staticpro (&QCdbus_system_bus);
1459
1460   QCdbus_session_bus = intern (":session");
1461   staticpro (&QCdbus_session_bus);
1462
1463   QCdbus_type_byte = intern (":byte");
1464   staticpro (&QCdbus_type_byte);
1465
1466   QCdbus_type_boolean = intern (":boolean");
1467   staticpro (&QCdbus_type_boolean);
1468
1469   QCdbus_type_int16 = intern (":int16");
1470   staticpro (&QCdbus_type_int16);
1471
1472   QCdbus_type_uint16 = intern (":uint16");
1473   staticpro (&QCdbus_type_uint16);
1474
1475   QCdbus_type_int32 = intern (":int32");
1476   staticpro (&QCdbus_type_int32);
1477
1478   QCdbus_type_uint32 = intern (":uint32");
1479   staticpro (&QCdbus_type_uint32);
1480
1481   QCdbus_type_int64 = intern (":int64");
1482   staticpro (&QCdbus_type_int64);
1483
1484   QCdbus_type_uint64 = intern (":uint64");
1485   staticpro (&QCdbus_type_uint64);
1486
1487   QCdbus_type_double = intern (":double");
1488   staticpro (&QCdbus_type_double);
1489
1490   QCdbus_type_string = intern (":string");
1491   staticpro (&QCdbus_type_string);
1492
1493   QCdbus_type_object_path = intern (":object-path");
1494   staticpro (&QCdbus_type_object_path);
1495
1496   QCdbus_type_signature = intern (":signature");
1497   staticpro (&QCdbus_type_signature);
1498
1499   QCdbus_type_array = intern (":array");
1500   staticpro (&QCdbus_type_array);
1501
1502   QCdbus_type_variant = intern (":variant");
1503   staticpro (&QCdbus_type_variant);
1504
1505   QCdbus_type_struct = intern (":struct");
1506   staticpro (&QCdbus_type_struct);
1507
1508   QCdbus_type_dict_entry = intern (":dict-entry");
1509   staticpro (&QCdbus_type_dict_entry);
1510
1511   DEFVAR_LISP ("dbus-registered-functions-table",
1512                &Vdbus_registered_functions_table,
1513     doc: /* Hash table of registered functions for D-Bus.
1514 The key in the hash table is the list (BUS INTERFACE MEMBER).  BUS is
1515 either the symbol `:system' or the symbol `:session'.  INTERFACE is a
1516 string which denotes a D-Bus interface, and MEMBER, also a string, is
1517 either a method or a signal INTERFACE is offering.  All arguments but
1518 BUS must not be nil.
1519
1520 The value in the hash table is a list of quadruple lists
1521 \((UNAME SERVICE PATH HANDLER) (UNAME SERVICE PATH HANDLER) ...).
1522 SERVICE is the service name as registered, UNAME is the corresponding
1523 unique name.  PATH is the object path of the sending object.  All of
1524 them can be nil, which means a wildcard then.  HANDLER is the function
1525 to be called when a D-Bus message, which matches the key criteria,
1526 arrives.  */);
1527   /* We initialize Vdbus_registered_functions_table in dbus.el,
1528      because we need to define a hash table function first.  */
1529   Vdbus_registered_functions_table = Qnil;
1530
1531   DEFVAR_LISP ("dbus-debug", &Vdbus_debug,
1532     doc: /* If non-nil, debug messages of D-Bus bindings are raised.  */);
1533 #ifdef DBUS_DEBUG
1534   Vdbus_debug = Qt;
1535 #else
1536   Vdbus_debug = Qnil;
1537 #endif
1538
1539   Fprovide (intern ("dbusbind"), Qnil);
1540
1541 }
1542
1543 #endif /* HAVE_DBUS */
1544
1545 /* arch-tag: 0e828477-b571-4fe4-b559-5c9211bc14b8
1546    (do not change this comment) */