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