src/dbusbind.c

   1 /* Elisp bindings for D-Bus.
   2    Copyright (C) 2007, 2008, 2009, 2010 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 <setjmp.h>
  26 #include "lisp.h"
  27 #include "frame.h"
  28 #include "termhooks.h"
  29 #include "keyboard.h"
  30
  31 \f
  32 /* Subroutines.  */
  33 Lisp_Object Qdbus_init_bus;
  34 Lisp_Object Qdbus_get_unique_name;
  35 Lisp_Object Qdbus_call_method;
  36 Lisp_Object Qdbus_call_method_asynchronously;
  37 Lisp_Object Qdbus_method_return_internal;
  38 Lisp_Object Qdbus_method_error_internal;
  39 Lisp_Object Qdbus_send_signal;
  40 Lisp_Object Qdbus_register_signal;
  41 Lisp_Object Qdbus_register_method;
  42
  43 /* D-Bus error symbol.  */
  44 Lisp_Object Qdbus_error;
  45
  46 /* Lisp symbols of the system and session buses.  */
  47 Lisp_Object QCdbus_system_bus, QCdbus_session_bus;
  48
  49 /* Lisp symbol for method call timeout.  */
  50 Lisp_Object QCdbus_timeout;
  51
  52 /* Lisp symbols of D-Bus types.  */
  53 Lisp_Object QCdbus_type_byte, QCdbus_type_boolean;
  54 Lisp_Object QCdbus_type_int16, QCdbus_type_uint16;
  55 Lisp_Object QCdbus_type_int32, QCdbus_type_uint32;
  56 Lisp_Object QCdbus_type_int64, QCdbus_type_uint64;
  57 Lisp_Object QCdbus_type_double, QCdbus_type_string;
  58 Lisp_Object QCdbus_type_object_path, QCdbus_type_signature;
  59 Lisp_Object QCdbus_type_array, QCdbus_type_variant;
  60 Lisp_Object QCdbus_type_struct, QCdbus_type_dict_entry;
  61
  62 /* Hash table which keeps function definitions.  */
  63 Lisp_Object Vdbus_registered_objects_table;
  64
  65 /* Whether to debug D-Bus.  */
  66 Lisp_Object Vdbus_debug;
  67
  68 /* Whether we are reading a D-Bus event.  */
  69 int xd_in_read_queued_messages = 0;
  70
  71 \f
  72 /* We use "xd_" and "XD_" as prefix for all internal symbols, because
  73    we don't want to poison other namespaces with "dbus_".  */
  74
  75 /* Raise a signal.  If we are reading events, we cannot signal; we
  76    throw to xd_read_queued_messages then.  */
  77 #define XD_SIGNAL1(arg)                                                 \
  78   do {                                                                  \
  79     if (xd_in_read_queued_messages)                                     \
  80       Fthrow (Qdbus_error, Qnil);                                       \
  81     else                                                                \
  82       xsignal1 (Qdbus_error, arg);                                      \
  83   } while (0)
  84
  85 #define XD_SIGNAL2(arg1, arg2)                                          \
  86   do {                                                                  \
  87     if (xd_in_read_queued_messages)                                     \
  88       Fthrow (Qdbus_error, Qnil);                                       \
  89     else                                                                \
  90       xsignal2 (Qdbus_error, arg1, arg2);                               \
  91   } while (0)
  92
  93 #define XD_SIGNAL3(arg1, arg2, arg3)                                    \
  94   do {                                                                  \
  95     if (xd_in_read_queued_messages)                                     \
  96       Fthrow (Qdbus_error, Qnil);                                       \
  97     else                                                                \
  98       xsignal3 (Qdbus_error, arg1, arg2, arg3);                         \
  99   } while (0)
 100
 101 /* Raise a Lisp error from a D-Bus ERROR.  */
 102 #define XD_ERROR(error)                                                 \
 103   do {                                                                  \
 104     char s[1024];                                                       \
 105     strncpy (s, error.message, 1023);                                   \
 106     dbus_error_free (&error);                                           \
 107     /* Remove the trailing newline.  */                                 \
 108     if (strchr (s, '\n') != NULL)                                       \
 109       s[strlen (s) - 1] = '\0';                                         \
 110     XD_SIGNAL1 (build_string (s));                                      \
 111   } while (0)
 112
 113 /* Macros for debugging.  In order to enable them, build with
 114    "make MYCPPFLAGS='-DDBUS_DEBUG -Wall'".  */
 115 #ifdef DBUS_DEBUG
 116 #define XD_DEBUG_MESSAGE(...)           \
 117   do {                                  \
 118     char s[1024];                       \
 119     snprintf (s, 1023, __VA_ARGS__);    \
 120     printf ("%s: %s\n", __func__, s);   \
 121     message ("%s: %s", __func__, s);    \
 122   } while (0)
 123 #define XD_DEBUG_VALID_LISP_OBJECT_P(object)                            \
 124   do {                                                                  \
 125     if (!valid_lisp_object_p (object))                                  \
 126       {                                                                 \
 127         XD_DEBUG_MESSAGE ("%d Assertion failure", __LINE__);            \
 128         XD_SIGNAL1 (build_string ("Assertion failure"));                \
 129       }                                                                 \
 130   } while (0)
 131
 132 #else /* !DBUS_DEBUG */
 133 #define XD_DEBUG_MESSAGE(...)                                           \
 134   do {                                                                  \
 135     if (!NILP (Vdbus_debug))                                            \
 136       {                                                                 \
 137         char s[1024];                                                   \
 138         snprintf (s, 1023, __VA_ARGS__);                                \
 139         message ("%s: %s", __func__, s);                                \
 140       }                                                                 \
 141   } while (0)
 142 #define XD_DEBUG_VALID_LISP_OBJECT_P(object)
 143 #endif
 144
 145 /* Check whether TYPE is a basic DBusType.  */
 146 #define XD_BASIC_DBUS_TYPE(type)                                        \
 147   ((type ==  DBUS_TYPE_BYTE)                                            \
 148    || (type ==  DBUS_TYPE_BOOLEAN)                                      \
 149    || (type ==  DBUS_TYPE_INT16)                                        \
 150    || (type ==  DBUS_TYPE_UINT16)                                       \
 151    || (type ==  DBUS_TYPE_INT32)                                        \
 152    || (type ==  DBUS_TYPE_UINT32)                                       \
 153    || (type ==  DBUS_TYPE_INT64)                                        \
 154    || (type ==  DBUS_TYPE_UINT64)                                       \
 155    || (type ==  DBUS_TYPE_DOUBLE)                                       \
 156    || (type ==  DBUS_TYPE_STRING)                                       \
 157    || (type ==  DBUS_TYPE_OBJECT_PATH)                                  \
 158    || (type ==  DBUS_TYPE_SIGNATURE))
 159
 160 /* This was a macro.  On Solaris 2.11 it was said to compile for
 161    hours, when optimzation is enabled.  So we have transferred it into
 162    a function.  */
 163 /* Determine the DBusType of a given Lisp symbol.  OBJECT must be one
 164    of the predefined D-Bus type symbols.  */
 165 static int
 166 xd_symbol_to_dbus_type (object)
 167      Lisp_Object object;
 168 {
 169   return
 170     ((EQ (object, QCdbus_type_byte)) ? DBUS_TYPE_BYTE
 171      : (EQ (object, QCdbus_type_boolean)) ? DBUS_TYPE_BOOLEAN
 172      : (EQ (object, QCdbus_type_int16)) ? DBUS_TYPE_INT16
 173      : (EQ (object, QCdbus_type_uint16)) ? DBUS_TYPE_UINT16
 174      : (EQ (object, QCdbus_type_int32)) ? DBUS_TYPE_INT32
 175      : (EQ (object, QCdbus_type_uint32)) ? DBUS_TYPE_UINT32
 176      : (EQ (object, QCdbus_type_int64)) ? DBUS_TYPE_INT64
 177      : (EQ (object, QCdbus_type_uint64)) ? DBUS_TYPE_UINT64
 178      : (EQ (object, QCdbus_type_double)) ? DBUS_TYPE_DOUBLE
 179      : (EQ (object, QCdbus_type_string)) ? DBUS_TYPE_STRING
 180      : (EQ (object, QCdbus_type_object_path)) ? DBUS_TYPE_OBJECT_PATH
 181      : (EQ (object, QCdbus_type_signature)) ? DBUS_TYPE_SIGNATURE
 182      : (EQ (object, QCdbus_type_array)) ? DBUS_TYPE_ARRAY
 183      : (EQ (object, QCdbus_type_variant)) ? DBUS_TYPE_VARIANT
 184      : (EQ (object, QCdbus_type_struct)) ? DBUS_TYPE_STRUCT
 185      : (EQ (object, QCdbus_type_dict_entry)) ? DBUS_TYPE_DICT_ENTRY
 186      : DBUS_TYPE_INVALID);
 187 }
 188
 189 /* Check whether a Lisp symbol is a predefined D-Bus type symbol.  */
 190 #define XD_DBUS_TYPE_P(object)                                          \
 191   (SYMBOLP (object) && ((xd_symbol_to_dbus_type (object) != DBUS_TYPE_INVALID)))
 192
 193 /* Determine the DBusType of a given Lisp OBJECT.  It is used to
 194    convert Lisp objects, being arguments of `dbus-call-method' or
 195    `dbus-send-signal', into corresponding C values appended as
 196    arguments to a D-Bus message.  */
 197 #define XD_OBJECT_TO_DBUS_TYPE(object)                                  \
 198   ((EQ (object, Qt) || EQ (object, Qnil)) ? DBUS_TYPE_BOOLEAN           \
 199    : (NATNUMP (object)) ? DBUS_TYPE_UINT32                              \
 200    : (INTEGERP (object)) ? DBUS_TYPE_INT32                              \
 201    : (FLOATP (object)) ? DBUS_TYPE_DOUBLE                               \
 202    : (STRINGP (object)) ? DBUS_TYPE_STRING                              \
 203    : (XD_DBUS_TYPE_P (object)) ? xd_symbol_to_dbus_type (object)        \
 204    : (CONSP (object))                                                   \
 205    ? ((XD_DBUS_TYPE_P (CAR_SAFE (object)))                              \
 206       ? ((XD_BASIC_DBUS_TYPE (xd_symbol_to_dbus_type (CAR_SAFE (object)))) \
 207          ? DBUS_TYPE_ARRAY                                              \
 208          : xd_symbol_to_dbus_type (CAR_SAFE (object)))                  \
 209       : DBUS_TYPE_ARRAY)                                                \
 210    : DBUS_TYPE_INVALID)
 211
 212 /* Return a list pointer which does not have a Lisp symbol as car.  */
 213 #define XD_NEXT_VALUE(object)                                           \
 214   ((XD_DBUS_TYPE_P (CAR_SAFE (object))) ? CDR_SAFE (object) : object)
 215
 216 /* Compute SIGNATURE of OBJECT.  It must have a form that it can be
 217    used in dbus_message_iter_open_container.  DTYPE is the DBusType
 218    the object is related to.  It is passed as argument, because it
 219    cannot be detected in basic type objects, when they are preceded by
 220    a type symbol.  PARENT_TYPE is the DBusType of a container this
 221    signature is embedded, or DBUS_TYPE_INVALID.  It is needed for the
 222    check that DBUS_TYPE_DICT_ENTRY occurs only as array element.  */
 223 static void
 224 xd_signature (signature, dtype, parent_type, object)
 225      char *signature;
 226      unsigned int dtype, parent_type;
 227      Lisp_Object object;
 228 {
 229   unsigned int subtype;
 230   Lisp_Object elt;
 231   char x[DBUS_MAXIMUM_SIGNATURE_LENGTH];
 232
 233   elt = object;
 234
 235   switch (dtype)
 236     {
 237     case DBUS_TYPE_BYTE:
 238     case DBUS_TYPE_UINT16:
 239     case DBUS_TYPE_UINT32:
 240     case DBUS_TYPE_UINT64:
 241       CHECK_NATNUM (object);
 242       sprintf (signature, "%c", dtype);
 243       break;
 244
 245     case DBUS_TYPE_BOOLEAN:
 246       if (!EQ (object, Qt) && !EQ (object, Qnil))
 247         wrong_type_argument (intern ("booleanp"), object);
 248       sprintf (signature, "%c", dtype);
 249       break;
 250
 251     case DBUS_TYPE_INT16:
 252     case DBUS_TYPE_INT32:
 253     case DBUS_TYPE_INT64:
 254       CHECK_NUMBER (object);
 255       sprintf (signature, "%c", dtype);
 256       break;
 257
 258     case DBUS_TYPE_DOUBLE:
 259       CHECK_FLOAT (object);
 260       sprintf (signature, "%c", dtype);
 261       break;
 262
 263     case DBUS_TYPE_STRING:
 264     case DBUS_TYPE_OBJECT_PATH:
 265     case DBUS_TYPE_SIGNATURE:
 266       CHECK_STRING (object);
 267       sprintf (signature, "%c", dtype);
 268       break;
 269
 270     case DBUS_TYPE_ARRAY:
 271       /* Check that all list elements have the same D-Bus type.  For
 272          complex element types, we just check the container type, not
 273          the whole element's signature.  */
 274       CHECK_CONS (object);
 275
 276       /* Type symbol is optional.  */
 277       if (EQ (QCdbus_type_array, CAR_SAFE (elt)))
 278         elt = XD_NEXT_VALUE (elt);
 279
 280       /* If the array is empty, DBUS_TYPE_STRING is the default
 281          element type.  */
 282       if (NILP (elt))
 283         {
 284           subtype = DBUS_TYPE_STRING;
 285           strcpy (x, DBUS_TYPE_STRING_AS_STRING);
 286         }
 287       else
 288         {
 289           subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
 290           xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
 291         }
 292
 293       /* If the element type is DBUS_TYPE_SIGNATURE, and this is the
 294          only element, the value of this element is used as he array's
 295          element signature.  */
 296       if ((subtype == DBUS_TYPE_SIGNATURE)
 297           && STRINGP (CAR_SAFE (XD_NEXT_VALUE (elt)))
 298           && NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
 299         strcpy (x, SDATA (CAR_SAFE (XD_NEXT_VALUE (elt))));
 300
 301       while (!NILP (elt))
 302         {
 303           if (subtype != XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt)))
 304             wrong_type_argument (intern ("D-Bus"), CAR_SAFE (elt));
 305           elt = CDR_SAFE (XD_NEXT_VALUE (elt));
 306         }
 307
 308       sprintf (signature, "%c%s", dtype, x);
 309       break;
 310
 311     case DBUS_TYPE_VARIANT:
 312       /* Check that there is exactly one list element.  */
 313       CHECK_CONS (object);
 314
 315       elt = XD_NEXT_VALUE (elt);
 316       subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
 317       xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
 318
 319       if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
 320         wrong_type_argument (intern ("D-Bus"),
 321                              CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt))));
 322
 323       sprintf (signature, "%c", dtype);
 324       break;
 325
 326     case DBUS_TYPE_STRUCT:
 327       /* A struct list might contain any number of elements with
 328          different types.  No further check needed.  */
 329       CHECK_CONS (object);
 330
 331       elt = XD_NEXT_VALUE (elt);
 332
 333       /* Compose the signature from the elements.  It is enclosed by
 334          parentheses.  */
 335       sprintf (signature, "%c", DBUS_STRUCT_BEGIN_CHAR );
 336       while (!NILP (elt))
 337         {
 338           subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
 339           xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
 340           strcat (signature, x);
 341           elt = CDR_SAFE (XD_NEXT_VALUE (elt));
 342         }
 343       strcat (signature, DBUS_STRUCT_END_CHAR_AS_STRING);
 344       break;
 345
 346     case DBUS_TYPE_DICT_ENTRY:
 347       /* Check that there are exactly two list elements, and the first
 348          one is of basic type.  The dictionary entry itself must be an
 349          element of an array.  */
 350       CHECK_CONS (object);
 351
 352       /* Check the parent object type.  */
 353       if (parent_type != DBUS_TYPE_ARRAY)
 354         wrong_type_argument (intern ("D-Bus"), object);
 355
 356       /* Compose the signature from the elements.  It is enclosed by
 357          curly braces.  */
 358       sprintf (signature, "%c", DBUS_DICT_ENTRY_BEGIN_CHAR);
 359
 360       /* First element.  */
 361       elt = XD_NEXT_VALUE (elt);
 362       subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
 363       xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
 364       strcat (signature, x);
 365
 366       if (!XD_BASIC_DBUS_TYPE (subtype))
 367         wrong_type_argument (intern ("D-Bus"), CAR_SAFE (XD_NEXT_VALUE (elt)));
 368
 369       /* Second element.  */
 370       elt = CDR_SAFE (XD_NEXT_VALUE (elt));
 371       subtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (elt));
 372       xd_signature (x, subtype, dtype, CAR_SAFE (XD_NEXT_VALUE (elt)));
 373       strcat (signature, x);
 374
 375       if (!NILP (CDR_SAFE (XD_NEXT_VALUE (elt))))
 376         wrong_type_argument (intern ("D-Bus"),
 377                              CAR_SAFE (CDR_SAFE (XD_NEXT_VALUE (elt))));
 378
 379       /* Closing signature.  */
 380       strcat (signature, DBUS_DICT_ENTRY_END_CHAR_AS_STRING);
 381       break;
 382
 383     default:
 384       wrong_type_argument (intern ("D-Bus"), object);
 385     }
 386
 387   XD_DEBUG_MESSAGE ("%s", signature);
 388 }
 389
 390 /* Append C value, extracted from Lisp OBJECT, to iteration ITER.
 391    DTYPE must be a valid DBusType.  It is used to convert Lisp
 392    objects, being arguments of `dbus-call-method' or
 393    `dbus-send-signal', into corresponding C values appended as
 394    arguments to a D-Bus message.  */
 395 static void
 396 xd_append_arg (dtype, object, iter)
 397      unsigned int dtype;
 398      Lisp_Object object;
 399      DBusMessageIter *iter;
 400 {
 401   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
 402   DBusMessageIter subiter;
 403
 404   if (XD_BASIC_DBUS_TYPE (dtype))
 405     switch (dtype)
 406       {
 407       case DBUS_TYPE_BYTE:
 408         {
 409           unsigned char val = XUINT (object) & 0xFF;
 410           XD_DEBUG_MESSAGE ("%c %d", dtype, val);
 411           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 412             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 413           return;
 414         }
 415
 416       case DBUS_TYPE_BOOLEAN:
 417         {
 418           dbus_bool_t val = (NILP (object)) ? FALSE : TRUE;
 419           XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true");
 420           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 421             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 422           return;
 423         }
 424
 425       case DBUS_TYPE_INT16:
 426         {
 427           dbus_int16_t val = XINT (object);
 428           XD_DEBUG_MESSAGE ("%c %d", dtype, (int) val);
 429           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 430             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 431           return;
 432         }
 433
 434       case DBUS_TYPE_UINT16:
 435         {
 436           dbus_uint16_t val = XUINT (object);
 437           XD_DEBUG_MESSAGE ("%c %u", dtype, (unsigned int) val);
 438           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 439             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 440           return;
 441         }
 442
 443       case DBUS_TYPE_INT32:
 444         {
 445           dbus_int32_t val = XINT (object);
 446           XD_DEBUG_MESSAGE ("%c %d", dtype, val);
 447           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 448             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 449           return;
 450         }
 451
 452       case DBUS_TYPE_UINT32:
 453         {
 454           dbus_uint32_t val = XUINT (object);
 455           XD_DEBUG_MESSAGE ("%c %u", dtype, val);
 456           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 457             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 458           return;
 459         }
 460
 461       case DBUS_TYPE_INT64:
 462         {
 463           dbus_int64_t val = XINT (object);
 464           XD_DEBUG_MESSAGE ("%c %d", dtype, (int) val);
 465           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 466             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 467           return;
 468         }
 469
 470       case DBUS_TYPE_UINT64:
 471         {
 472           dbus_uint64_t val = XUINT (object);
 473           XD_DEBUG_MESSAGE ("%c %u", dtype, (unsigned int) val);
 474           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 475             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 476           return;
 477         }
 478
 479       case DBUS_TYPE_DOUBLE:
 480         {
 481           double val = XFLOAT_DATA (object);
 482           XD_DEBUG_MESSAGE ("%c %f", dtype, val);
 483           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 484             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 485           return;
 486         }
 487
 488       case DBUS_TYPE_STRING:
 489       case DBUS_TYPE_OBJECT_PATH:
 490       case DBUS_TYPE_SIGNATURE:
 491         {
 492           char *val = SDATA (Fstring_make_unibyte (object));
 493           XD_DEBUG_MESSAGE ("%c %s", dtype, val);
 494           if (!dbus_message_iter_append_basic (iter, dtype, &val))
 495             XD_SIGNAL2 (build_string ("Unable to append argument"), object);
 496           return;
 497         }
 498       }
 499
 500   else /* Compound types.  */
 501     {
 502
 503       /* All compound types except array have a type symbol.  For
 504          array, it is optional.  Skip it.  */
 505       if (!XD_BASIC_DBUS_TYPE (XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object))))
 506         object = XD_NEXT_VALUE (object);
 507
 508       /* Open new subiteration.  */
 509       switch (dtype)
 510         {
 511         case DBUS_TYPE_ARRAY:
 512           /* An array has only elements of the same type.  So it is
 513              sufficient to check the first element's signature
 514              only.  */
 515
 516           if (NILP (object))
 517             /* If the array is empty, DBUS_TYPE_STRING is the default
 518                element type.  */
 519             strcpy (signature, DBUS_TYPE_STRING_AS_STRING);
 520
 521           else
 522             /* If the element type is DBUS_TYPE_SIGNATURE, and this is
 523                the only element, the value of this element is used as
 524                the array's element signature.  */
 525             if ((XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object))
 526                  == DBUS_TYPE_SIGNATURE)
 527                 && STRINGP (CAR_SAFE (XD_NEXT_VALUE (object)))
 528                 && NILP (CDR_SAFE (XD_NEXT_VALUE (object))))
 529               {
 530                 strcpy (signature, SDATA (CAR_SAFE (XD_NEXT_VALUE (object))));
 531                 object = CDR_SAFE (XD_NEXT_VALUE (object));
 532               }
 533
 534             else
 535               xd_signature (signature,
 536                             XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object)),
 537                             dtype, CAR_SAFE (XD_NEXT_VALUE (object)));
 538
 539           XD_DEBUG_MESSAGE ("%c %s %s", dtype, signature,
 540                             SDATA (format2 ("%s", object, Qnil)));
 541           if (!dbus_message_iter_open_container (iter, dtype,
 542                                                  signature, &subiter))
 543             XD_SIGNAL3 (build_string ("Cannot open container"),
 544                         make_number (dtype), build_string (signature));
 545           break;
 546
 547         case DBUS_TYPE_VARIANT:
 548           /* A variant has just one element.  */
 549           xd_signature (signature, XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object)),
 550                         dtype, CAR_SAFE (XD_NEXT_VALUE (object)));
 551
 552           XD_DEBUG_MESSAGE ("%c %s %s", dtype, signature,
 553                             SDATA (format2 ("%s", object, Qnil)));
 554           if (!dbus_message_iter_open_container (iter, dtype,
 555                                                  signature, &subiter))
 556             XD_SIGNAL3 (build_string ("Cannot open container"),
 557                         make_number (dtype), build_string (signature));
 558           break;
 559
 560         case DBUS_TYPE_STRUCT:
 561         case DBUS_TYPE_DICT_ENTRY:
 562           /* These containers do not require a signature.  */
 563           XD_DEBUG_MESSAGE ("%c %s", dtype,
 564                             SDATA (format2 ("%s", object, Qnil)));
 565           if (!dbus_message_iter_open_container (iter, dtype, NULL, &subiter))
 566             XD_SIGNAL2 (build_string ("Cannot open container"),
 567                         make_number (dtype));
 568           break;
 569         }
 570
 571       /* Loop over list elements.  */
 572       while (!NILP (object))
 573         {
 574           dtype = XD_OBJECT_TO_DBUS_TYPE (CAR_SAFE (object));
 575           object = XD_NEXT_VALUE (object);
 576
 577           xd_append_arg (dtype, CAR_SAFE (object), &subiter);
 578
 579           object = CDR_SAFE (object);
 580         }
 581
 582       /* Close the subiteration.  */
 583       if (!dbus_message_iter_close_container (iter, &subiter))
 584         XD_SIGNAL2 (build_string ("Cannot close container"),
 585                     make_number (dtype));
 586     }
 587 }
 588
 589 /* Retrieve C value from a DBusMessageIter structure ITER, and return
 590    a converted Lisp object.  The type DTYPE of the argument of the
 591    D-Bus message must be a valid DBusType.  Compound D-Bus types
 592    result always in a Lisp list.  */
 593 static Lisp_Object
 594 xd_retrieve_arg (dtype, iter)
 595      unsigned int dtype;
 596      DBusMessageIter *iter;
 597 {
 598
 599   switch (dtype)
 600     {
 601     case DBUS_TYPE_BYTE:
 602       {
 603         unsigned int val;
 604         dbus_message_iter_get_basic (iter, &val);
 605         val = val & 0xFF;
 606         XD_DEBUG_MESSAGE ("%c %d", dtype, val);
 607         return make_number (val);
 608       }
 609
 610     case DBUS_TYPE_BOOLEAN:
 611       {
 612         dbus_bool_t val;
 613         dbus_message_iter_get_basic (iter, &val);
 614         XD_DEBUG_MESSAGE ("%c %s", dtype, (val == FALSE) ? "false" : "true");
 615         return (val == FALSE) ? Qnil : Qt;
 616       }
 617
 618     case DBUS_TYPE_INT16:
 619       {
 620         dbus_int16_t val;
 621         dbus_message_iter_get_basic (iter, &val);
 622         XD_DEBUG_MESSAGE ("%c %d", dtype, val);
 623         return make_number (val);
 624       }
 625
 626     case DBUS_TYPE_UINT16:
 627       {
 628         dbus_uint16_t val;
 629         dbus_message_iter_get_basic (iter, &val);
 630         XD_DEBUG_MESSAGE ("%c %d", dtype, val);
 631         return make_number (val);
 632       }
 633
 634     case DBUS_TYPE_INT32:
 635       {
 636         dbus_int32_t val;
 637         dbus_message_iter_get_basic (iter, &val);
 638         XD_DEBUG_MESSAGE ("%c %d", dtype, val);
 639         return make_fixnum_or_float (val);
 640       }
 641
 642     case DBUS_TYPE_UINT32:
 643       {
 644         dbus_uint32_t val;
 645         dbus_message_iter_get_basic (iter, &val);
 646         XD_DEBUG_MESSAGE ("%c %d", dtype, val);
 647         return make_fixnum_or_float (val);
 648       }
 649
 650     case DBUS_TYPE_INT64:
 651       {
 652         dbus_int64_t val;
 653         dbus_message_iter_get_basic (iter, &val);
 654         XD_DEBUG_MESSAGE ("%c %d", dtype, (int) val);
 655         return make_fixnum_or_float (val);
 656       }
 657
 658     case DBUS_TYPE_UINT64:
 659       {
 660         dbus_uint64_t val;
 661         dbus_message_iter_get_basic (iter, &val);
 662         XD_DEBUG_MESSAGE ("%c %d", dtype, (int) val);
 663         return make_fixnum_or_float (val);
 664       }
 665
 666     case DBUS_TYPE_DOUBLE:
 667       {
 668         double val;
 669         dbus_message_iter_get_basic (iter, &val);
 670         XD_DEBUG_MESSAGE ("%c %f", dtype, val);
 671         return make_float (val);
 672       }
 673
 674     case DBUS_TYPE_STRING:
 675     case DBUS_TYPE_OBJECT_PATH:
 676     case DBUS_TYPE_SIGNATURE:
 677       {
 678         char *val;
 679         dbus_message_iter_get_basic (iter, &val);
 680         XD_DEBUG_MESSAGE ("%c %s", dtype, val);
 681         return build_string (val);
 682       }
 683
 684     case DBUS_TYPE_ARRAY:
 685     case DBUS_TYPE_VARIANT:
 686     case DBUS_TYPE_STRUCT:
 687     case DBUS_TYPE_DICT_ENTRY:
 688       {
 689         Lisp_Object result;
 690         struct gcpro gcpro1;
 691         DBusMessageIter subiter;
 692         int subtype;
 693         result = Qnil;
 694         GCPRO1 (result);
 695         dbus_message_iter_recurse (iter, &subiter);
 696         while ((subtype = dbus_message_iter_get_arg_type (&subiter))
 697                != DBUS_TYPE_INVALID)
 698           {
 699             result = Fcons (xd_retrieve_arg (subtype, &subiter), result);
 700             dbus_message_iter_next (&subiter);
 701           }
 702         XD_DEBUG_MESSAGE ("%c %s", dtype, SDATA (format2 ("%s", result, Qnil)));
 703         RETURN_UNGCPRO (Fnreverse (result));
 704       }
 705
 706     default:
 707       XD_DEBUG_MESSAGE ("DBusType '%c' not supported", dtype);
 708       return Qnil;
 709     }
 710 }
 711
 712 /* Initialize D-Bus connection.  BUS is a Lisp symbol, either :system
 713    or :session.  It tells which D-Bus to be initialized.  */
 714 static DBusConnection *
 715 xd_initialize (bus)
 716      Lisp_Object bus;
 717 {
 718   DBusConnection *connection;
 719   DBusError derror;
 720
 721   /* Parameter check.  */
 722   CHECK_SYMBOL (bus);
 723   if (!(EQ (bus, QCdbus_system_bus) || EQ (bus, QCdbus_session_bus)))
 724     XD_SIGNAL2 (build_string ("Wrong bus name"), bus);
 725
 726   /* We do not want to have an autolaunch for the session bus.  */
 727   if (EQ (bus, QCdbus_session_bus)
 728       && getenv ("DBUS_SESSION_BUS_ADDRESS") == NULL)
 729     XD_SIGNAL2 (build_string ("No connection to bus"), bus);
 730
 731   /* Open a connection to the bus.  */
 732   dbus_error_init (&derror);
 733
 734   if (EQ (bus, QCdbus_system_bus))
 735     connection = dbus_bus_get (DBUS_BUS_SYSTEM, &derror);
 736   else
 737     connection = dbus_bus_get (DBUS_BUS_SESSION, &derror);
 738
 739   if (dbus_error_is_set (&derror))
 740     XD_ERROR (derror);
 741
 742   if (connection == NULL)
 743     XD_SIGNAL2 (build_string ("No connection to bus"), bus);
 744
 745   /* Cleanup.  */
 746   dbus_error_free (&derror);
 747
 748   /* Return the result.  */
 749   return connection;
 750 }
 751
 752
 753 /* Add connection file descriptor to input_wait_mask, in order to
 754    let select() detect, whether a new message has been arrived.  */
 755 dbus_bool_t
 756 xd_add_watch (watch, data)
 757      DBusWatch *watch;
 758      void *data;
 759 {
 760   /* We check only for incoming data.  */
 761   if (dbus_watch_get_flags (watch) & DBUS_WATCH_READABLE)
 762     {
 763 #if HAVE_DBUS_WATCH_GET_UNIX_FD
 764       /* TODO: Reverse these on Win32, which prefers the opposite.  */
 765       int fd = dbus_watch_get_unix_fd(watch);
 766       if (fd == -1)
 767         fd = dbus_watch_get_socket(watch);
 768 #else
 769       int fd = dbus_watch_get_fd(watch);
 770 #endif
 771       XD_DEBUG_MESSAGE ("fd %d", fd);
 772
 773       if (fd == -1)
 774         return FALSE;
 775
 776       /* Add the file descriptor to input_wait_mask.  */
 777       add_keyboard_wait_descriptor (fd);
 778     }
 779
 780   /* Return.  */
 781   return TRUE;
 782 }
 783
 784 /* Remove connection file descriptor from input_wait_mask.  DATA is
 785    the used bus, either QCdbus_system_bus or QCdbus_session_bus.  */
 786 void
 787 xd_remove_watch (watch, data)
 788      DBusWatch *watch;
 789      void *data;
 790 {
 791   /* We check only for incoming data.  */
 792   if (dbus_watch_get_flags (watch) & DBUS_WATCH_READABLE)
 793     {
 794 #if HAVE_DBUS_WATCH_GET_UNIX_FD
 795       /* TODO: Reverse these on Win32, which prefers the opposite.  */
 796       int fd = dbus_watch_get_unix_fd(watch);
 797       if (fd == -1)
 798         fd = dbus_watch_get_socket(watch);
 799 #else
 800       int fd = dbus_watch_get_fd(watch);
 801 #endif
 802       XD_DEBUG_MESSAGE ("fd %d", fd);
 803
 804       if (fd == -1)
 805         return;
 806
 807       /* Unset session environment.  */
 808       if ((data != NULL) && (data == (void*) XHASH (QCdbus_session_bus)))
 809         {
 810           XD_DEBUG_MESSAGE ("unsetenv DBUS_SESSION_BUS_ADDRESS");
 811           unsetenv ("DBUS_SESSION_BUS_ADDRESS");
 812         }
 813
 814       /* Remove the file descriptor from input_wait_mask.  */
 815       delete_keyboard_wait_descriptor (fd);
 816     }
 817
 818   /* Return.  */
 819   return;
 820 }
 821
 822 DEFUN ("dbus-init-bus", Fdbus_init_bus, Sdbus_init_bus, 1, 1, 0,
 823        doc: /* Initialize connection to D-Bus BUS.
 824 This is an internal function, it shall not be used outside dbus.el.  */)
 825      (bus)
 826      Lisp_Object bus;
 827 {
 828   DBusConnection *connection;
 829
 830   /* Check parameters.  */
 831   CHECK_SYMBOL (bus);
 832
 833   /* Open a connection to the bus.  */
 834   connection = xd_initialize (bus);
 835
 836   /* Add the watch functions.  We pass also the bus as data, in order
 837      to distinguish between the busses in xd_remove_watch.  */
 838   if (!dbus_connection_set_watch_functions (connection,
 839                                             xd_add_watch,
 840                                             xd_remove_watch,
 841                                             NULL, (void*) XHASH (bus), NULL))
 842     XD_SIGNAL1 (build_string ("Cannot add watch functions"));
 843
 844   /* Return.  */
 845   return Qnil;
 846 }
 847
 848 DEFUN ("dbus-get-unique-name", Fdbus_get_unique_name, Sdbus_get_unique_name,
 849        1, 1, 0,
 850        doc: /* Return the unique name of Emacs registered at D-Bus BUS.  */)
 851      (bus)
 852      Lisp_Object bus;
 853 {
 854   DBusConnection *connection;
 855   const char *name;
 856
 857   /* Check parameters.  */
 858   CHECK_SYMBOL (bus);
 859
 860   /* Open a connection to the bus.  */
 861   connection = xd_initialize (bus);
 862
 863   /* Request the name.  */
 864   name = dbus_bus_get_unique_name (connection);
 865   if (name == NULL)
 866     XD_SIGNAL1 (build_string ("No unique name available"));
 867
 868   /* Return.  */
 869   return build_string (name);
 870 }
 871
 872 DEFUN ("dbus-call-method", Fdbus_call_method, Sdbus_call_method, 5, MANY, 0,
 873        doc: /* Call METHOD on the D-Bus BUS.
 874
 875 BUS is either the symbol `:system' or the symbol `:session'.
 876
 877 SERVICE is the D-Bus service name to be used.  PATH is the D-Bus
 878 object path SERVICE is registered at.  INTERFACE is an interface
 879 offered by SERVICE.  It must provide METHOD.
 880
 881 If the parameter `:timeout' is given, the following integer TIMEOUT
 882 specifies the maximum number of milliseconds the method call must
 883 return.  The default value is 25,000.  If the method call doesn't
 884 return in time, a D-Bus error is raised.
 885
 886 All other arguments ARGS are passed to METHOD as arguments.  They are
 887 converted into D-Bus types via the following rules:
 888
 889   t and nil => DBUS_TYPE_BOOLEAN
 890   number    => DBUS_TYPE_UINT32
 891   integer   => DBUS_TYPE_INT32
 892   float     => DBUS_TYPE_DOUBLE
 893   string    => DBUS_TYPE_STRING
 894   list      => DBUS_TYPE_ARRAY
 895
 896 All arguments can be preceded by a type symbol.  For details about
 897 type symbols, see Info node `(dbus)Type Conversion'.
 898
 899 `dbus-call-method' returns the resulting values of METHOD as a list of
 900 Lisp objects.  The type conversion happens the other direction as for
 901 input arguments.  It follows the mapping rules:
 902
 903   DBUS_TYPE_BOOLEAN     => t or nil
 904   DBUS_TYPE_BYTE        => number
 905   DBUS_TYPE_UINT16      => number
 906   DBUS_TYPE_INT16       => integer
 907   DBUS_TYPE_UINT32      => number or float
 908   DBUS_TYPE_INT32       => integer or float
 909   DBUS_TYPE_UINT64      => number or float
 910   DBUS_TYPE_INT64       => integer or float
 911   DBUS_TYPE_DOUBLE      => float
 912   DBUS_TYPE_STRING      => string
 913   DBUS_TYPE_OBJECT_PATH => string
 914   DBUS_TYPE_SIGNATURE   => string
 915   DBUS_TYPE_ARRAY       => list
 916   DBUS_TYPE_VARIANT     => list
 917   DBUS_TYPE_STRUCT      => list
 918   DBUS_TYPE_DICT_ENTRY  => list
 919
 920 Example:
 921
 922 \(dbus-call-method
 923   :session "org.gnome.seahorse" "/org/gnome/seahorse/keys/openpgp"
 924   "org.gnome.seahorse.Keys" "GetKeyField"
 925   "openpgp:657984B8C7A966DD" "simple-name")
 926
 927   => (t ("Philip R. Zimmermann"))
 928
 929 If the result of the METHOD call is just one value, the converted Lisp
 930 object is returned instead of a list containing this single Lisp object.
 931
 932 \(dbus-call-method
 933   :system "org.freedesktop.Hal" "/org/freedesktop/Hal/devices/computer"
 934   "org.freedesktop.Hal.Device" "GetPropertyString"
 935   "system.kernel.machine")
 936
 937   => "i686"
 938
 939 usage: (dbus-call-method BUS SERVICE PATH INTERFACE METHOD &optional :timeout TIMEOUT &rest ARGS)  */)
 940      (nargs, args)
 941      int nargs;
 942      register Lisp_Object *args;
 943 {
 944   Lisp_Object bus, service, path, interface, method;
 945   Lisp_Object result;
 946   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
 947   DBusConnection *connection;
 948   DBusMessage *dmessage;
 949   DBusMessage *reply;
 950   DBusMessageIter iter;
 951   DBusError derror;
 952   unsigned int dtype;
 953   int timeout = -1;
 954   int i = 5;
 955   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
 956
 957   /* Check parameters.  */
 958   bus = args[0];
 959   service = args[1];
 960   path = args[2];
 961   interface = args[3];
 962   method = args[4];
 963
 964   CHECK_SYMBOL (bus);
 965   CHECK_STRING (service);
 966   CHECK_STRING (path);
 967   CHECK_STRING (interface);
 968   CHECK_STRING (method);
 969   GCPRO5 (bus, service, path, interface, method);
 970
 971   XD_DEBUG_MESSAGE ("%s %s %s %s",
 972                     SDATA (service),
 973                     SDATA (path),
 974                     SDATA (interface),
 975                     SDATA (method));
 976
 977   /* Open a connection to the bus.  */
 978   connection = xd_initialize (bus);
 979
 980   /* Create the message.  */
 981   dmessage = dbus_message_new_method_call (SDATA (service),
 982                                            SDATA (path),
 983                                            SDATA (interface),
 984                                            SDATA (method));
 985   UNGCPRO;
 986   if (dmessage == NULL)
 987     XD_SIGNAL1 (build_string ("Unable to create a new message"));
 988
 989   /* Check for timeout parameter.  */
 990   if ((i+2 <= nargs) && (EQ ((args[i]), QCdbus_timeout)))
 991     {
 992       CHECK_NATNUM (args[i+1]);
 993       timeout = XUINT (args[i+1]);
 994       i = i+2;
 995     }
 996
 997   /* Initialize parameter list of message.  */
 998   dbus_message_iter_init_append (dmessage, &iter);
 999
1000   /* Append parameters to the message.  */
1001   for (; i < nargs; ++i)
1002     {
1003       dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1004       if (XD_DBUS_TYPE_P (args[i]))
1005         {
1006           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1007           XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1008           XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-4,
1009                             SDATA (format2 ("%s", args[i], Qnil)),
1010                             SDATA (format2 ("%s", args[i+1], Qnil)));
1011           ++i;
1012         }
1013       else
1014         {
1015           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1016           XD_DEBUG_MESSAGE ("Parameter%d %s", i-4,
1017                             SDATA (format2 ("%s", args[i], Qnil)));
1018         }
1019
1020       /* Check for valid signature.  We use DBUS_TYPE_INVALID as
1021          indication that there is no parent type.  */
1022       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1023
1024       xd_append_arg (dtype, args[i], &iter);
1025     }
1026
1027   /* Send the message.  */
1028   dbus_error_init (&derror);
1029   reply = dbus_connection_send_with_reply_and_block (connection,
1030                                                      dmessage,
1031                                                      timeout,
1032                                                      &derror);
1033
1034   if (dbus_error_is_set (&derror))
1035     XD_ERROR (derror);
1036
1037   if (reply == NULL)
1038     XD_SIGNAL1 (build_string ("No reply"));
1039
1040   XD_DEBUG_MESSAGE ("Message sent");
1041
1042   /* Collect the results.  */
1043   result = Qnil;
1044   GCPRO1 (result);
1045
1046   if (dbus_message_iter_init (reply, &iter))
1047     {
1048       /* Loop over the parameters of the D-Bus reply message.  Construct a
1049          Lisp list, which is returned by `dbus-call-method'.  */
1050       while ((dtype = dbus_message_iter_get_arg_type (&iter))
1051              != DBUS_TYPE_INVALID)
1052         {
1053           result = Fcons (xd_retrieve_arg (dtype, &iter), result);
1054           dbus_message_iter_next (&iter);
1055         }
1056     }
1057   else
1058     {
1059       /* No arguments: just return nil.  */
1060     }
1061
1062   /* Cleanup.  */
1063   dbus_error_free (&derror);
1064   dbus_message_unref (dmessage);
1065   dbus_message_unref (reply);
1066
1067   /* Return the result.  If there is only one single Lisp object,
1068      return it as-it-is, otherwise return the reversed list.  */
1069   if (XUINT (Flength (result)) == 1)
1070     RETURN_UNGCPRO (CAR_SAFE (result));
1071   else
1072     RETURN_UNGCPRO (Fnreverse (result));
1073 }
1074
1075 DEFUN ("dbus-call-method-asynchronously", Fdbus_call_method_asynchronously,
1076        Sdbus_call_method_asynchronously, 6, MANY, 0,
1077        doc: /* Call METHOD on the D-Bus BUS asynchronously.
1078
1079 BUS is either the symbol `:system' or the symbol `:session'.
1080
1081 SERVICE is the D-Bus service name to be used.  PATH is the D-Bus
1082 object path SERVICE is registered at.  INTERFACE is an interface
1083 offered by SERVICE.  It must provide METHOD.
1084
1085 HANDLER is a Lisp function, which is called when the corresponding
1086 return message has arrived.  If HANDLER is nil, no return message will
1087 be expected.
1088
1089 If the parameter `:timeout' is given, the following integer TIMEOUT
1090 specifies the maximum number of milliseconds the method call must
1091 return.  The default value is 25,000.  If the method call doesn't
1092 return in time, a D-Bus error is raised.
1093
1094 All other arguments ARGS are passed to METHOD as arguments.  They are
1095 converted into D-Bus types via the following rules:
1096
1097   t and nil => DBUS_TYPE_BOOLEAN
1098   number    => DBUS_TYPE_UINT32
1099   integer   => DBUS_TYPE_INT32
1100   float     => DBUS_TYPE_DOUBLE
1101   string    => DBUS_TYPE_STRING
1102   list      => DBUS_TYPE_ARRAY
1103
1104 All arguments can be preceded by a type symbol.  For details about
1105 type symbols, see Info node `(dbus)Type Conversion'.
1106
1107 Unless HANDLER is nil, the function returns a key into the hash table
1108 `dbus-registered-objects-table'.  The corresponding entry in the hash
1109 table is removed, when the return message has been arrived, and
1110 HANDLER is called.
1111
1112 Example:
1113
1114 \(dbus-call-method-asynchronously
1115   :system "org.freedesktop.Hal" "/org/freedesktop/Hal/devices/computer"
1116   "org.freedesktop.Hal.Device" "GetPropertyString" 'message
1117   "system.kernel.machine")
1118
1119   => (:system 2)
1120
1121   -| i686
1122
1123 usage: (dbus-call-method-asynchronously BUS SERVICE PATH INTERFACE METHOD HANDLER &optional :timeout TIMEOUT &rest ARGS)  */)
1124      (nargs, args)
1125      int nargs;
1126      register Lisp_Object *args;
1127 {
1128   Lisp_Object bus, service, path, interface, method, handler;
1129   Lisp_Object result;
1130   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5, gcpro6;
1131   DBusConnection *connection;
1132   DBusMessage *dmessage;
1133   DBusMessageIter iter;
1134   unsigned int dtype;
1135   int timeout = -1;
1136   int i = 6;
1137   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1138
1139   /* Check parameters.  */
1140   bus = args[0];
1141   service = args[1];
1142   path = args[2];
1143   interface = args[3];
1144   method = args[4];
1145   handler = args[5];
1146
1147   CHECK_SYMBOL (bus);
1148   CHECK_STRING (service);
1149   CHECK_STRING (path);
1150   CHECK_STRING (interface);
1151   CHECK_STRING (method);
1152   if (!NILP (handler) && !FUNCTIONP (handler))
1153     wrong_type_argument (intern ("functionp"), handler);
1154   GCPRO6 (bus, service, path, interface, method, handler);
1155
1156   XD_DEBUG_MESSAGE ("%s %s %s %s",
1157                     SDATA (service),
1158                     SDATA (path),
1159                     SDATA (interface),
1160                     SDATA (method));
1161
1162   /* Open a connection to the bus.  */
1163   connection = xd_initialize (bus);
1164
1165   /* Create the message.  */
1166   dmessage = dbus_message_new_method_call (SDATA (service),
1167                                            SDATA (path),
1168                                            SDATA (interface),
1169                                            SDATA (method));
1170   if (dmessage == NULL)
1171     XD_SIGNAL1 (build_string ("Unable to create a new message"));
1172
1173   /* Check for timeout parameter.  */
1174   if ((i+2 <= nargs) && (EQ ((args[i]), QCdbus_timeout)))
1175     {
1176       CHECK_NATNUM (args[i+1]);
1177       timeout = XUINT (args[i+1]);
1178       i = i+2;
1179     }
1180
1181   /* Initialize parameter list of message.  */
1182   dbus_message_iter_init_append (dmessage, &iter);
1183
1184   /* Append parameters to the message.  */
1185   for (; i < nargs; ++i)
1186     {
1187       dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1188       if (XD_DBUS_TYPE_P (args[i]))
1189         {
1190           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1191           XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1192           XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-4,
1193                             SDATA (format2 ("%s", args[i], Qnil)),
1194                             SDATA (format2 ("%s", args[i+1], Qnil)));
1195           ++i;
1196         }
1197       else
1198         {
1199           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1200           XD_DEBUG_MESSAGE ("Parameter%d %s", i-4,
1201                             SDATA (format2 ("%s", args[i], Qnil)));
1202         }
1203
1204       /* Check for valid signature.  We use DBUS_TYPE_INVALID as
1205          indication that there is no parent type.  */
1206       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1207
1208       xd_append_arg (dtype, args[i], &iter);
1209     }
1210
1211   if (!NILP (handler))
1212     {
1213       /* Send the message.  The message is just added to the outgoing
1214          message queue.  */
1215       if (!dbus_connection_send_with_reply (connection, dmessage,
1216                                             NULL, timeout))
1217         XD_SIGNAL1 (build_string ("Cannot send message"));
1218
1219       /* The result is the key in Vdbus_registered_objects_table.  */
1220       result = (list2 (bus, make_number (dbus_message_get_serial (dmessage))));
1221
1222       /* Create a hash table entry.  */
1223       Fputhash (result, handler, Vdbus_registered_objects_table);
1224     }
1225   else
1226     {
1227       /* Send the message.  The message is just added to the outgoing
1228          message queue.  */
1229       if (!dbus_connection_send (connection, dmessage, NULL))
1230         XD_SIGNAL1 (build_string ("Cannot send message"));
1231
1232       result = Qnil;
1233     }
1234
1235   /* Flush connection to ensure the message is handled.  */
1236   dbus_connection_flush (connection);
1237
1238   XD_DEBUG_MESSAGE ("Message sent");
1239
1240   /* Cleanup.  */
1241   dbus_message_unref (dmessage);
1242
1243   /* Return the result.  */
1244   RETURN_UNGCPRO (result);
1245 }
1246
1247 DEFUN ("dbus-method-return-internal", Fdbus_method_return_internal,
1248        Sdbus_method_return_internal,
1249        3, MANY, 0,
1250        doc: /* Return for message SERIAL on the D-Bus BUS.
1251 This is an internal function, it shall not be used outside dbus.el.
1252
1253 usage: (dbus-method-return-internal BUS SERIAL SERVICE &rest ARGS)  */)
1254      (nargs, args)
1255      int nargs;
1256      register Lisp_Object *args;
1257 {
1258   Lisp_Object bus, serial, service;
1259   struct gcpro gcpro1, gcpro2, gcpro3;
1260   DBusConnection *connection;
1261   DBusMessage *dmessage;
1262   DBusMessageIter iter;
1263   unsigned int dtype;
1264   int i;
1265   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1266
1267   /* Check parameters.  */
1268   bus = args[0];
1269   serial = args[1];
1270   service = args[2];
1271
1272   CHECK_SYMBOL (bus);
1273   CHECK_NUMBER (serial);
1274   CHECK_STRING (service);
1275   GCPRO3 (bus, serial, service);
1276
1277   XD_DEBUG_MESSAGE ("%lu %s ", (unsigned long) XUINT (serial), SDATA (service));
1278
1279   /* Open a connection to the bus.  */
1280   connection = xd_initialize (bus);
1281
1282   /* Create the message.  */
1283   dmessage = dbus_message_new (DBUS_MESSAGE_TYPE_METHOD_RETURN);
1284   if ((dmessage == NULL)
1285       || (!dbus_message_set_reply_serial (dmessage, XUINT (serial)))
1286       || (!dbus_message_set_destination (dmessage, SDATA (service))))
1287     {
1288       UNGCPRO;
1289       XD_SIGNAL1 (build_string ("Unable to create a return message"));
1290     }
1291
1292   UNGCPRO;
1293
1294   /* Initialize parameter list of message.  */
1295   dbus_message_iter_init_append (dmessage, &iter);
1296
1297   /* Append parameters to the message.  */
1298   for (i = 3; i < nargs; ++i)
1299     {
1300       dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1301       if (XD_DBUS_TYPE_P (args[i]))
1302         {
1303           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1304           XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1305           XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-2,
1306                             SDATA (format2 ("%s", args[i], Qnil)),
1307                             SDATA (format2 ("%s", args[i+1], Qnil)));
1308           ++i;
1309         }
1310       else
1311         {
1312           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1313           XD_DEBUG_MESSAGE ("Parameter%d %s", i-2,
1314                             SDATA (format2 ("%s", args[i], Qnil)));
1315         }
1316
1317       /* Check for valid signature.  We use DBUS_TYPE_INVALID as
1318          indication that there is no parent type.  */
1319       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1320
1321       xd_append_arg (dtype, args[i], &iter);
1322     }
1323
1324   /* Send the message.  The message is just added to the outgoing
1325      message queue.  */
1326   if (!dbus_connection_send (connection, dmessage, NULL))
1327     XD_SIGNAL1 (build_string ("Cannot send message"));
1328
1329   /* Flush connection to ensure the message is handled.  */
1330   dbus_connection_flush (connection);
1331
1332   XD_DEBUG_MESSAGE ("Message sent");
1333
1334   /* Cleanup.  */
1335   dbus_message_unref (dmessage);
1336
1337   /* Return.  */
1338   return Qt;
1339 }
1340
1341 DEFUN ("dbus-method-error-internal", Fdbus_method_error_internal,
1342        Sdbus_method_error_internal,
1343        3, MANY, 0,
1344        doc: /* Return error message for message SERIAL on the D-Bus BUS.
1345 This is an internal function, it shall not be used outside dbus.el.
1346
1347 usage: (dbus-method-error-internal BUS SERIAL SERVICE &rest ARGS)  */)
1348      (nargs, args)
1349      int nargs;
1350      register Lisp_Object *args;
1351 {
1352   Lisp_Object bus, serial, service;
1353   struct gcpro gcpro1, gcpro2, gcpro3;
1354   DBusConnection *connection;
1355   DBusMessage *dmessage;
1356   DBusMessageIter iter;
1357   unsigned int dtype;
1358   int i;
1359   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1360
1361   /* Check parameters.  */
1362   bus = args[0];
1363   serial = args[1];
1364   service = args[2];
1365
1366   CHECK_SYMBOL (bus);
1367   CHECK_NUMBER (serial);
1368   CHECK_STRING (service);
1369   GCPRO3 (bus, serial, service);
1370
1371   XD_DEBUG_MESSAGE ("%lu %s ", (unsigned long) XUINT (serial), SDATA (service));
1372
1373   /* Open a connection to the bus.  */
1374   connection = xd_initialize (bus);
1375
1376   /* Create the message.  */
1377   dmessage = dbus_message_new (DBUS_MESSAGE_TYPE_ERROR);
1378   if ((dmessage == NULL)
1379       || (!dbus_message_set_error_name (dmessage, DBUS_ERROR_FAILED))
1380       || (!dbus_message_set_reply_serial (dmessage, XUINT (serial)))
1381       || (!dbus_message_set_destination (dmessage, SDATA (service))))
1382     {
1383       UNGCPRO;
1384       XD_SIGNAL1 (build_string ("Unable to create a error message"));
1385     }
1386
1387   UNGCPRO;
1388
1389   /* Initialize parameter list of message.  */
1390   dbus_message_iter_init_append (dmessage, &iter);
1391
1392   /* Append parameters to the message.  */
1393   for (i = 3; i < nargs; ++i)
1394     {
1395       dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1396       if (XD_DBUS_TYPE_P (args[i]))
1397         {
1398           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1399           XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1400           XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-2,
1401                             SDATA (format2 ("%s", args[i], Qnil)),
1402                             SDATA (format2 ("%s", args[i+1], Qnil)));
1403           ++i;
1404         }
1405       else
1406         {
1407           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1408           XD_DEBUG_MESSAGE ("Parameter%d %s", i-2,
1409                             SDATA (format2 ("%s", args[i], Qnil)));
1410         }
1411
1412       /* Check for valid signature.  We use DBUS_TYPE_INVALID as
1413          indication that there is no parent type.  */
1414       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1415
1416       xd_append_arg (dtype, args[i], &iter);
1417     }
1418
1419   /* Send the message.  The message is just added to the outgoing
1420      message queue.  */
1421   if (!dbus_connection_send (connection, dmessage, NULL))
1422     XD_SIGNAL1 (build_string ("Cannot send message"));
1423
1424   /* Flush connection to ensure the message is handled.  */
1425   dbus_connection_flush (connection);
1426
1427   XD_DEBUG_MESSAGE ("Message sent");
1428
1429   /* Cleanup.  */
1430   dbus_message_unref (dmessage);
1431
1432   /* Return.  */
1433   return Qt;
1434 }
1435
1436 DEFUN ("dbus-send-signal", Fdbus_send_signal, Sdbus_send_signal, 5, MANY, 0,
1437        doc: /* Send signal SIGNAL on the D-Bus BUS.
1438
1439 BUS is either the symbol `:system' or the symbol `:session'.
1440
1441 SERVICE is the D-Bus service name SIGNAL is sent from.  PATH is the
1442 D-Bus object path SERVICE is registered at.  INTERFACE is an interface
1443 offered by SERVICE.  It must provide signal SIGNAL.
1444
1445 All other arguments ARGS are passed to SIGNAL as arguments.  They are
1446 converted into D-Bus types via the following rules:
1447
1448   t and nil => DBUS_TYPE_BOOLEAN
1449   number    => DBUS_TYPE_UINT32
1450   integer   => DBUS_TYPE_INT32
1451   float     => DBUS_TYPE_DOUBLE
1452   string    => DBUS_TYPE_STRING
1453   list      => DBUS_TYPE_ARRAY
1454
1455 All arguments can be preceded by a type symbol.  For details about
1456 type symbols, see Info node `(dbus)Type Conversion'.
1457
1458 Example:
1459
1460 \(dbus-send-signal
1461   :session "org.gnu.Emacs" "/org/gnu/Emacs"
1462   "org.gnu.Emacs.FileManager" "FileModified" "/home/albinus/.emacs")
1463
1464 usage: (dbus-send-signal BUS SERVICE PATH INTERFACE SIGNAL &rest ARGS)  */)
1465      (nargs, args)
1466      int nargs;
1467      register Lisp_Object *args;
1468 {
1469   Lisp_Object bus, service, path, interface, signal;
1470   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
1471   DBusConnection *connection;
1472   DBusMessage *dmessage;
1473   DBusMessageIter iter;
1474   unsigned int dtype;
1475   int i;
1476   char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1477
1478   /* Check parameters.  */
1479   bus = args[0];
1480   service = args[1];
1481   path = args[2];
1482   interface = args[3];
1483   signal = args[4];
1484
1485   CHECK_SYMBOL (bus);
1486   CHECK_STRING (service);
1487   CHECK_STRING (path);
1488   CHECK_STRING (interface);
1489   CHECK_STRING (signal);
1490   GCPRO5 (bus, service, path, interface, signal);
1491
1492   XD_DEBUG_MESSAGE ("%s %s %s %s",
1493                     SDATA (service),
1494                     SDATA (path),
1495                     SDATA (interface),
1496                     SDATA (signal));
1497
1498   /* Open a connection to the bus.  */
1499   connection = xd_initialize (bus);
1500
1501   /* Create the message.  */
1502   dmessage = dbus_message_new_signal (SDATA (path),
1503                                       SDATA (interface),
1504                                       SDATA (signal));
1505   UNGCPRO;
1506   if (dmessage == NULL)
1507     XD_SIGNAL1 (build_string ("Unable to create a new message"));
1508
1509   /* Initialize parameter list of message.  */
1510   dbus_message_iter_init_append (dmessage, &iter);
1511
1512   /* Append parameters to the message.  */
1513   for (i = 5; i < nargs; ++i)
1514     {
1515       dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1516       if (XD_DBUS_TYPE_P (args[i]))
1517         {
1518           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1519           XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1520           XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-4,
1521                             SDATA (format2 ("%s", args[i], Qnil)),
1522                             SDATA (format2 ("%s", args[i+1], Qnil)));
1523           ++i;
1524         }
1525       else
1526         {
1527           XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1528           XD_DEBUG_MESSAGE ("Parameter%d %s", i-4,
1529                             SDATA (format2 ("%s", args[i], Qnil)));
1530         }
1531
1532       /* Check for valid signature.  We use DBUS_TYPE_INVALID as
1533          indication that there is no parent type.  */
1534       xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1535
1536       xd_append_arg (dtype, args[i], &iter);
1537     }
1538
1539   /* Send the message.  The message is just added to the outgoing
1540      message queue.  */
1541   if (!dbus_connection_send (connection, dmessage, NULL))
1542     XD_SIGNAL1 (build_string ("Cannot send message"));
1543
1544   /* Flush connection to ensure the message is handled.  */
1545   dbus_connection_flush (connection);
1546
1547   XD_DEBUG_MESSAGE ("Signal sent");
1548
1549   /* Cleanup.  */
1550   dbus_message_unref (dmessage);
1551
1552   /* Return.  */
1553   return Qt;
1554 }
1555
1556 /* Check, whether there is pending input in the message queue of the
1557    D-Bus BUS.  BUS is a Lisp symbol, either :system or :session.  */
1558 int
1559 xd_get_dispatch_status (bus)
1560      Lisp_Object bus;
1561 {
1562   DBusConnection *connection;
1563
1564   /* Open a connection to the bus.  */
1565   connection = xd_initialize (bus);
1566
1567   /* Non blocking read of the next available message.  */
1568   dbus_connection_read_write (connection, 0);
1569
1570   /* Return.  */
1571   return
1572     (dbus_connection_get_dispatch_status (connection)
1573      == DBUS_DISPATCH_DATA_REMAINS)
1574     ? TRUE : FALSE;
1575 }
1576
1577 /* Check for queued incoming messages from the system and session buses.  */
1578 int
1579 xd_pending_messages ()
1580 {
1581
1582   /* Vdbus_registered_objects_table will be initialized as hash table
1583      in dbus.el.  When this package isn't loaded yet, it doesn't make
1584      sense to handle D-Bus messages.  */
1585   return (HASH_TABLE_P (Vdbus_registered_objects_table)
1586           ? (xd_get_dispatch_status (QCdbus_system_bus)
1587              || ((getenv ("DBUS_SESSION_BUS_ADDRESS") != NULL)
1588                  ? xd_get_dispatch_status (QCdbus_session_bus)
1589                  : FALSE))
1590           : FALSE);
1591 }
1592
1593 /* Read queued incoming message of the D-Bus BUS.  BUS is a Lisp
1594    symbol, either :system or :session.  */
1595 static Lisp_Object
1596 xd_read_message (bus)
1597      Lisp_Object bus;
1598 {
1599   Lisp_Object args, key, value;
1600   struct gcpro gcpro1;
1601   struct input_event event;
1602   DBusConnection *connection;
1603   DBusMessage *dmessage;
1604   DBusMessageIter iter;
1605   unsigned int dtype;
1606   int mtype, serial;
1607   const char *uname, *path, *interface, *member;
1608
1609   /* Open a connection to the bus.  */
1610   connection = xd_initialize (bus);
1611
1612   /* Non blocking read of the next available message.  */
1613   dbus_connection_read_write (connection, 0);
1614   dmessage = dbus_connection_pop_message (connection);
1615
1616   /* Return if there is no queued message.  */
1617   if (dmessage == NULL)
1618     return Qnil;
1619
1620   /* Collect the parameters.  */
1621   args = Qnil;
1622   GCPRO1 (args);
1623
1624   /* Loop over the resulting parameters.  Construct a list.  */
1625   if (dbus_message_iter_init (dmessage, &iter))
1626     {
1627       while ((dtype = dbus_message_iter_get_arg_type (&iter))
1628              != DBUS_TYPE_INVALID)
1629         {
1630           args = Fcons (xd_retrieve_arg (dtype, &iter), args);
1631           dbus_message_iter_next (&iter);
1632         }
1633       /* The arguments are stored in reverse order.  Reorder them.  */
1634       args = Fnreverse (args);
1635     }
1636
1637   /* Read message type, message serial, unique name, object path,
1638      interface and member from the message.  */
1639   mtype = dbus_message_get_type (dmessage);
1640   serial =
1641     ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1642      || (mtype == DBUS_MESSAGE_TYPE_ERROR))
1643     ? dbus_message_get_reply_serial (dmessage)
1644     : dbus_message_get_serial (dmessage);
1645   uname = dbus_message_get_sender (dmessage);
1646   path = dbus_message_get_path (dmessage);
1647   interface = dbus_message_get_interface (dmessage);
1648   member = dbus_message_get_member (dmessage);
1649
1650   XD_DEBUG_MESSAGE ("Event received: %s %d %s %s %s %s %s",
1651                     (mtype == DBUS_MESSAGE_TYPE_INVALID)
1652                     ? "DBUS_MESSAGE_TYPE_INVALID"
1653                     : (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1654                     ? "DBUS_MESSAGE_TYPE_METHOD_CALL"
1655                     : (mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1656                     ? "DBUS_MESSAGE_TYPE_METHOD_RETURN"
1657                     : (mtype == DBUS_MESSAGE_TYPE_ERROR)
1658                     ? "DBUS_MESSAGE_TYPE_ERROR"
1659                     : "DBUS_MESSAGE_TYPE_SIGNAL",
1660                     serial, uname, path, interface, member,
1661                     SDATA (format2 ("%s", args, Qnil)));
1662
1663   if ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1664       || (mtype == DBUS_MESSAGE_TYPE_ERROR))
1665     {
1666       /* Search for a registered function of the message.  */
1667       key = list2 (bus, make_number (serial));
1668       value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1669
1670       /* There shall be exactly one entry.  Construct an event.  */
1671       if (NILP (value))
1672         goto cleanup;
1673
1674       /* Remove the entry.  */
1675       Fremhash (key, Vdbus_registered_objects_table);
1676
1677       /* Construct an event.  */
1678       EVENT_INIT (event);
1679       event.kind = DBUS_EVENT;
1680       event.frame_or_window = Qnil;
1681       event.arg = Fcons (value, args);
1682     }
1683
1684   else /* (mtype != DBUS_MESSAGE_TYPE_METHOD_RETURN)  */
1685     {
1686       /* Vdbus_registered_objects_table requires non-nil interface and
1687          member.  */
1688       if ((interface == NULL) || (member == NULL))
1689         goto cleanup;
1690
1691       /* Search for a registered function of the message.  */
1692       key = list3 (bus, build_string (interface), build_string (member));
1693       value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1694
1695       /* Loop over the registered functions.  Construct an event.  */
1696       while (!NILP (value))
1697         {
1698           key = CAR_SAFE (value);
1699           /* key has the structure (UNAME SERVICE PATH HANDLER).  */
1700           if (((uname == NULL)
1701                || (NILP (CAR_SAFE (key)))
1702                || (strcmp (uname, SDATA (CAR_SAFE (key))) == 0))
1703               && ((path == NULL)
1704                   || (NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1705                   || (strcmp (path,
1706                               SDATA (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1707                       == 0))
1708               && (!NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))))))
1709             {
1710               EVENT_INIT (event);
1711               event.kind = DBUS_EVENT;
1712               event.frame_or_window = Qnil;
1713               event.arg = Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))),
1714                                  args);
1715               break;
1716             }
1717           value = CDR_SAFE (value);
1718         }
1719
1720       if (NILP (value))
1721         goto cleanup;
1722     }
1723
1724   /* Add type, serial, uname, path, interface and member to the event.  */
1725   event.arg = Fcons ((member == NULL ? Qnil : build_string (member)),
1726                      event.arg);
1727   event.arg = Fcons ((interface == NULL ? Qnil : build_string (interface)),
1728                      event.arg);
1729   event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
1730                      event.arg);
1731   event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
1732                      event.arg);
1733   event.arg = Fcons (make_number (serial), event.arg);
1734   event.arg = Fcons (make_number (mtype), event.arg);
1735
1736   /* Add the bus symbol to the event.  */
1737   event.arg = Fcons (bus, event.arg);
1738
1739   /* Store it into the input event queue.  */
1740   kbd_buffer_store_event (&event);
1741
1742   XD_DEBUG_MESSAGE ("Event stored: %s",
1743                     SDATA (format2 ("%s", event.arg, Qnil)));
1744
1745   /* Cleanup.  */
1746  cleanup:
1747   dbus_message_unref (dmessage);
1748
1749   RETURN_UNGCPRO (Qnil);
1750 }
1751
1752 /* Read queued incoming messages from the system and session buses.  */
1753 void
1754 xd_read_queued_messages ()
1755 {
1756
1757   /* Vdbus_registered_objects_table will be initialized as hash table
1758      in dbus.el.  When this package isn't loaded yet, it doesn't make
1759      sense to handle D-Bus messages.  Furthermore, we ignore all Lisp
1760      errors during the call.  */
1761   if (HASH_TABLE_P (Vdbus_registered_objects_table))
1762     {
1763       xd_in_read_queued_messages = 1;
1764       internal_catch (Qdbus_error, xd_read_message, QCdbus_system_bus);
1765       internal_catch (Qdbus_error, xd_read_message, QCdbus_session_bus);
1766       xd_in_read_queued_messages = 0;
1767     }
1768 }
1769
1770 DEFUN ("dbus-register-signal", Fdbus_register_signal, Sdbus_register_signal,
1771        6, MANY, 0,
1772        doc: /* Register for signal SIGNAL on the D-Bus BUS.
1773
1774 BUS is either the symbol `:system' or the symbol `:session'.
1775
1776 SERVICE is the D-Bus service name used by the sending D-Bus object.
1777 It can be either a known name or the unique name of the D-Bus object
1778 sending the signal.  When SERVICE is nil, related signals from all
1779 D-Bus objects shall be accepted.
1780
1781 PATH is the D-Bus object path SERVICE is registered.  It can also be
1782 nil if the path name of incoming signals shall not be checked.
1783
1784 INTERFACE is an interface offered by SERVICE.  It must provide SIGNAL.
1785 HANDLER is a Lisp function to be called when the signal is received.
1786 It must accept as arguments the values SIGNAL is sending.
1787
1788 All other arguments ARGS, if specified, must be strings.  They stand
1789 for the respective arguments of the signal in their order, and are
1790 used for filtering as well.  A nil argument might be used to preserve
1791 the order.
1792
1793 INTERFACE, SIGNAL and HANDLER must not be nil.  Example:
1794
1795 \(defun my-signal-handler (device)
1796   (message "Device %s added" device))
1797
1798 \(dbus-register-signal
1799   :system "org.freedesktop.Hal" "/org/freedesktop/Hal/Manager"
1800   "org.freedesktop.Hal.Manager" "DeviceAdded" 'my-signal-handler)
1801
1802   => ((:system "org.freedesktop.Hal.Manager" "DeviceAdded")
1803       ("org.freedesktop.Hal" "/org/freedesktop/Hal/Manager" my-signal-handler))
1804
1805 `dbus-register-signal' returns an object, which can be used in
1806 `dbus-unregister-object' for removing the registration.
1807
1808 usage: (dbus-register-signal BUS SERVICE PATH INTERFACE SIGNAL HANDLER &rest ARGS) */)
1809      (nargs, args)
1810      int nargs;
1811      register Lisp_Object *args;
1812 {
1813   Lisp_Object bus, service, path, interface, signal, handler;
1814   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5, gcpro6;
1815   Lisp_Object uname, key, key1, value;
1816   DBusConnection *connection;
1817   int i;
1818   char rule[DBUS_MAXIMUM_MATCH_RULE_LENGTH];
1819   char x[DBUS_MAXIMUM_MATCH_RULE_LENGTH];
1820   DBusError derror;
1821
1822   /* Check parameters.  */
1823   bus = args[0];
1824   service = args[1];
1825   path = args[2];
1826   interface = args[3];
1827   signal = args[4];
1828   handler = args[5];
1829
1830   CHECK_SYMBOL (bus);
1831   if (!NILP (service)) CHECK_STRING (service);
1832   if (!NILP (path)) CHECK_STRING (path);
1833   CHECK_STRING (interface);
1834   CHECK_STRING (signal);
1835   if (!FUNCTIONP (handler))
1836     wrong_type_argument (intern ("functionp"), handler);
1837   GCPRO6 (bus, service, path, interface, signal, handler);
1838
1839   /* Retrieve unique name of service.  If service is a known name, we
1840      will register for the corresponding unique name, if any.  Signals
1841      are sent always with the unique name as sender.  Note: the unique
1842      name of "org.freedesktop.DBus" is that string itself.  */
1843   if ((STRINGP (service))
1844       && (SBYTES (service) > 0)
1845       && (strcmp (SDATA (service), DBUS_SERVICE_DBUS) != 0)
1846       && (strncmp (SDATA (service), ":", 1) != 0))
1847     {
1848       uname = call2 (intern ("dbus-get-name-owner"), bus, service);
1849       /* When there is no unique name, we mark it with an empty
1850          string.  */
1851       if (NILP (uname))
1852         uname = empty_unibyte_string;
1853     }
1854   else
1855     uname = service;
1856
1857   /* Create a matching rule if the unique name exists (when no
1858      wildcard).  */
1859   if (NILP (uname) || (SBYTES (uname) > 0))
1860     {
1861       /* Open a connection to the bus.  */
1862       connection = xd_initialize (bus);
1863
1864       /* Create a rule to receive related signals.  */
1865       sprintf (rule,
1866                "type='signal',interface='%s',member='%s'",
1867                SDATA (interface),
1868                SDATA (signal));
1869
1870       /* Add unique name and path to the rule if they are non-nil.  */
1871       if (!NILP (uname))
1872         {
1873           sprintf (x, ",sender='%s'", SDATA (uname));
1874           strcat (rule, x);
1875         }
1876
1877       if (!NILP (path))
1878         {
1879           sprintf (x, ",path='%s'", SDATA (path));
1880           strcat (rule, x);
1881         }
1882
1883       /* Add arguments to the rule if they are non-nil.  */
1884       for (i = 6; i < nargs; ++i)
1885         if (!NILP (args[i]))
1886           {
1887             CHECK_STRING (args[i]);
1888             sprintf (x, ",arg%d='%s'", i-6, SDATA (args[i]));
1889             strcat (rule, x);
1890           }
1891
1892       /* Add the rule to the bus.  */
1893       dbus_error_init (&derror);
1894       dbus_bus_add_match (connection, rule, &derror);
1895       if (dbus_error_is_set (&derror))
1896         {
1897           UNGCPRO;
1898           XD_ERROR (derror);
1899         }
1900
1901       /* Cleanup.  */
1902       dbus_error_free (&derror);
1903
1904       XD_DEBUG_MESSAGE ("Matching rule \"%s\" created", rule);
1905     }
1906
1907   /* Create a hash table entry.  */
1908   key = list3 (bus, interface, signal);
1909   key1 = list4 (uname, service, path, handler);
1910   value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1911
1912   if (NILP (Fmember (key1, value)))
1913     Fputhash (key, Fcons (key1, value), Vdbus_registered_objects_table);
1914
1915   /* Return object.  */
1916   RETURN_UNGCPRO (list2 (key, list3 (service, path, handler)));
1917 }
1918
1919 DEFUN ("dbus-register-method", Fdbus_register_method, Sdbus_register_method,
1920        6, 6, 0,
1921        doc: /* Register for method METHOD on the D-Bus BUS.
1922
1923 BUS is either the symbol `:system' or the symbol `:session'.
1924
1925 SERVICE is the D-Bus service name of the D-Bus object METHOD is
1926 registered for.  It must be a known name.
1927
1928 PATH is the D-Bus object path SERVICE is registered.  INTERFACE is the
1929 interface offered by SERVICE.  It must provide METHOD.  HANDLER is a
1930 Lisp function to be called when a method call is received.  It must
1931 accept the input arguments of METHOD.  The return value of HANDLER is
1932 used for composing the returning D-Bus message.  */)
1933      (bus, service, path, interface, method, handler)
1934      Lisp_Object bus, service, path, interface, method, handler;
1935 {
1936   Lisp_Object key, key1, value;
1937   DBusConnection *connection;
1938   int result;
1939   DBusError derror;
1940
1941   /* Check parameters.  */
1942   CHECK_SYMBOL (bus);
1943   CHECK_STRING (service);
1944   CHECK_STRING (path);
1945   CHECK_STRING (interface);
1946   CHECK_STRING (method);
1947   if (!FUNCTIONP (handler))
1948     wrong_type_argument (intern ("functionp"), handler);
1949   /* TODO: We must check for a valid service name, otherwise there is
1950      a segmentation fault.  */
1951
1952   /* Open a connection to the bus.  */
1953   connection = xd_initialize (bus);
1954
1955   /* Request the known name from the bus.  We can ignore the result,
1956      it is set to -1 if there is an error - kind of redundancy.  */
1957   dbus_error_init (&derror);
1958   result = dbus_bus_request_name (connection, SDATA (service), 0, &derror);
1959   if (dbus_error_is_set (&derror))
1960     XD_ERROR (derror);
1961
1962   /* Create a hash table entry.  We use nil for the unique name,
1963      because the method might be called from anybody.  */
1964   key = list3 (bus, interface, method);
1965   key1 = list4 (Qnil, service, path, handler);
1966   value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1967
1968   if (NILP (Fmember (key1, value)))
1969     Fputhash (key, Fcons (key1, value), Vdbus_registered_objects_table);
1970
1971   /* Cleanup.  */
1972   dbus_error_free (&derror);
1973
1974   /* Return object.  */
1975   return list2 (key, list3 (service, path, handler));
1976 }
1977
1978 \f
1979 void
1980 syms_of_dbusbind ()
1981 {
1982
1983   Qdbus_init_bus = intern_c_string ("dbus-init-bus");
1984   staticpro (&Qdbus_init_bus);
1985   defsubr (&Sdbus_init_bus);
1986
1987   Qdbus_get_unique_name = intern_c_string ("dbus-get-unique-name");
1988   staticpro (&Qdbus_get_unique_name);
1989   defsubr (&Sdbus_get_unique_name);
1990
1991   Qdbus_call_method = intern_c_string ("dbus-call-method");
1992   staticpro (&Qdbus_call_method);
1993   defsubr (&Sdbus_call_method);
1994
1995   Qdbus_call_method_asynchronously = intern_c_string ("dbus-call-method-asynchronously");
1996   staticpro (&Qdbus_call_method_asynchronously);
1997   defsubr (&Sdbus_call_method_asynchronously);
1998
1999   Qdbus_method_return_internal = intern_c_string ("dbus-method-return-internal");
2000   staticpro (&Qdbus_method_return_internal);
2001   defsubr (&Sdbus_method_return_internal);
2002
2003   Qdbus_method_error_internal = intern_c_string ("dbus-method-error-internal");
2004   staticpro (&Qdbus_method_error_internal);
2005   defsubr (&Sdbus_method_error_internal);
2006
2007   Qdbus_send_signal = intern_c_string ("dbus-send-signal");
2008   staticpro (&Qdbus_send_signal);
2009   defsubr (&Sdbus_send_signal);
2010
2011   Qdbus_register_signal = intern_c_string ("dbus-register-signal");
2012   staticpro (&Qdbus_register_signal);
2013   defsubr (&Sdbus_register_signal);
2014
2015   Qdbus_register_method = intern_c_string ("dbus-register-method");
2016   staticpro (&Qdbus_register_method);
2017   defsubr (&Sdbus_register_method);
2018
2019   Qdbus_error = intern_c_string ("dbus-error");
2020   staticpro (&Qdbus_error);
2021   Fput (Qdbus_error, Qerror_conditions,
2022         list2 (Qdbus_error, Qerror));
2023   Fput (Qdbus_error, Qerror_message,
2024         make_pure_c_string ("D-Bus error"));
2025
2026   QCdbus_system_bus = intern_c_string (":system");
2027   staticpro (&QCdbus_system_bus);
2028
2029   QCdbus_session_bus = intern_c_string (":session");
2030   staticpro (&QCdbus_session_bus);
2031
2032   QCdbus_timeout = intern_c_string (":timeout");
2033   staticpro (&QCdbus_timeout);
2034
2035   QCdbus_type_byte = intern_c_string (":byte");
2036   staticpro (&QCdbus_type_byte);
2037
2038   QCdbus_type_boolean = intern_c_string (":boolean");
2039   staticpro (&QCdbus_type_boolean);
2040
2041   QCdbus_type_int16 = intern_c_string (":int16");
2042   staticpro (&QCdbus_type_int16);
2043
2044   QCdbus_type_uint16 = intern_c_string (":uint16");
2045   staticpro (&QCdbus_type_uint16);
2046
2047   QCdbus_type_int32 = intern_c_string (":int32");
2048   staticpro (&QCdbus_type_int32);
2049
2050   QCdbus_type_uint32 = intern_c_string (":uint32");
2051   staticpro (&QCdbus_type_uint32);
2052
2053   QCdbus_type_int64 = intern_c_string (":int64");
2054   staticpro (&QCdbus_type_int64);
2055
2056   QCdbus_type_uint64 = intern_c_string (":uint64");
2057   staticpro (&QCdbus_type_uint64);
2058
2059   QCdbus_type_double = intern_c_string (":double");
2060   staticpro (&QCdbus_type_double);
2061
2062   QCdbus_type_string = intern_c_string (":string");
2063   staticpro (&QCdbus_type_string);
2064
2065   QCdbus_type_object_path = intern_c_string (":object-path");
2066   staticpro (&QCdbus_type_object_path);
2067
2068   QCdbus_type_signature = intern_c_string (":signature");
2069   staticpro (&QCdbus_type_signature);
2070
2071   QCdbus_type_array = intern_c_string (":array");
2072   staticpro (&QCdbus_type_array);
2073
2074   QCdbus_type_variant = intern_c_string (":variant");
2075   staticpro (&QCdbus_type_variant);
2076
2077   QCdbus_type_struct = intern_c_string (":struct");
2078   staticpro (&QCdbus_type_struct);
2079
2080   QCdbus_type_dict_entry = intern_c_string (":dict-entry");
2081   staticpro (&QCdbus_type_dict_entry);
2082
2083   DEFVAR_LISP ("dbus-registered-objects-table",
2084                &Vdbus_registered_objects_table,
2085     doc: /* Hash table of registered functions for D-Bus.
2086 There are two different uses of the hash table: for accessing
2087 registered interfaces properties, targeted by signals or method calls,
2088 and for calling handlers in case of non-blocking method call returns.
2089
2090 In the first case, the key in the hash table is the list (BUS
2091 INTERFACE MEMBER).  BUS is either the symbol `:system' or the symbol
2092 `:session'.  INTERFACE is a string which denotes a D-Bus interface,
2093 and MEMBER, also a string, is either a method, a signal or a property
2094 INTERFACE is offering.  All arguments but BUS must not be nil.
2095
2096 The value in the hash table is a list of quadruple lists
2097 \((UNAME SERVICE PATH OBJECT) (UNAME SERVICE PATH OBJECT) ...).
2098 SERVICE is the service name as registered, UNAME is the corresponding
2099 unique name.  In case of registered methods and properties, UNAME is
2100 nil.  PATH is the object path of the sending object.  All of them can
2101 be nil, which means a wildcard then.  OBJECT is either the handler to
2102 be called when a D-Bus message, which matches the key criteria,
2103 arrives (methods and signals), or a cons cell containing the value of
2104 the property.
2105
2106 In the second case, the key in the hash table is the list (BUS SERIAL).
2107 BUS is either the symbol `:system' or the symbol `:session'.  SERIAL
2108 is the serial number of the non-blocking method call, a reply is
2109 expected.  Both arguments must not be nil.  The value in the hash
2110 table is HANDLER, the function to be called when the D-Bus reply
2111 message arrives.  */);
2112   /* We initialize Vdbus_registered_objects_table in dbus.el, because
2113      we need to define a hash table function first.  */
2114   Vdbus_registered_objects_table = Qnil;
2115
2116   DEFVAR_LISP ("dbus-debug", &Vdbus_debug,
2117     doc: /* If non-nil, debug messages of D-Bus bindings are raised.  */);
2118 #ifdef DBUS_DEBUG
2119   Vdbus_debug = Qt;
2120 #else
2121   Vdbus_debug = Qnil;
2122 #endif
2123
2124   Fprovide (intern_c_string ("dbusbind"), Qnil);
2125
2126 }
2127
2128 #endif /* HAVE_DBUS */
2129
2130 /* arch-tag: 0e828477-b571-4fe4-b559-5c9211bc14b8
2131    (do not change this comment) */