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