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