src/dbusbind.c

   1 /* Elisp bindings for D-Bus.
   2    Copyright (C) 2007 Free Software Foundation, Inc.
   3
   4 This file is part of GNU Emacs.
   5
   6 GNU Emacs is free software; you can redistribute it and/or modify
   7 it under the terms of the GNU General Public License as published by
   8 the Free Software Foundation; either version 3, or (at your option)
   9 any later version.
  10
  11 GNU Emacs is distributed in the hope that it will be useful,
  12 but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 GNU General Public License for more details.
  15
  16 You should have received a copy of the GNU General Public License
  17 along with GNU Emacs; see the file COPYING.  If not, write to
  18 the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  19 Boston, MA 02110-1301, USA.  */
  20
  21 #include "config.h"
  22
  23 #ifdef HAVE_DBUS
  24 #include <stdlib.h>
  25 #include <stdio.h>
  26 #include <dbus/dbus.h>
  27 #include "lisp.h"
  28 #include "frame.h"
  29 #include "termhooks.h"
  30 #include "keyboard.h"
  31
  32 \f
  33 /* Subroutines.  */
  34 Lisp_Object Qdbus_get_unique_name;
  35 Lisp_Object Qdbus_call_method;
  36 Lisp_Object Qdbus_send_signal;
  37 Lisp_Object Qdbus_register_signal;
  38 Lisp_Object Qdbus_unregister_signal;
  39
  40 /* D-Bus error symbol.  */
  41 Lisp_Object Qdbus_error;
  42
  43 /* Lisp symbols of the system and session buses.  */
  44 Lisp_Object QCdbus_system_bus, QCdbus_session_bus;
  45
  46 /* Lisp symbols of D-Bus types.  */
  47 Lisp_Object QCdbus_type_byte, QCdbus_type_boolean;
  48 Lisp_Object QCdbus_type_int16, QCdbus_type_uint16;
  49 Lisp_Object QCdbus_type_int32, QCdbus_type_uint32;
  50 Lisp_Object QCdbus_type_int64, QCdbus_type_uint64;
  51 Lisp_Object QCdbus_type_double, QCdbus_type_string;
  52 Lisp_Object QCdbus_type_object_path, QCdbus_type_signature;
  53 Lisp_Object QCdbus_type_array, QCdbus_type_variant;
  54 Lisp_Object QCdbus_type_struct, QCdbus_type_dict_entry;
  55
  56 /* Hash table which keeps function definitions.  */
  57 Lisp_Object Vdbus_registered_functions_table;
  58
  59 /* Whether to debug D-Bus.  */
  60 Lisp_Object Vdbus_debug;
  61
  62 \f
  63 /* We use "xd_" and "XD_" as prefix for all internal symbols, because
  64    we don't want to poison other namespaces with "dbus_".  */
  65
  66 /* Raise a Lisp error from a D-Bus ERROR.  */
  67 #define XD_ERROR(error)                                                 \
  68   {                                                                     \
  69     char s[1024];                                                       \
  70     strcpy (s, error.message);                                          \
  71     dbus_error_free (&error);                                           \
  72     /* Remove the trailing newline.  */                                 \
  73     if (strchr (s, '\n') != NULL)                                       \
  74       s[strlen (s) - 1] = '\0';                                         \
  75     xsignal1 (Qdbus_error, build_string (s));                           \
  76   }
  77
  78 /* Macros for debugging.  In order to enable them, build with
  79    "make MYCPPFLAGS='-DDBUS_DEBUG'".  */
  80 #ifdef DBUS_DEBUG
  81 #define XD_DEBUG_MESSAGE(...)           \
  82   {                                     \
  83     char s[1024];                       \
  84     sprintf (s, __VA_ARGS__);           \
  85     printf ("%s: %s\n", __func__, s);   \
  86     message ("%s: %s", __func__, s);    \
  87   }
  88 #define XD_DEBUG_VALID_LISP_OBJECT_P(object)                            \
  89   if (!valid_lisp_object_p (object))                                    \
  90     {                                                                   \
  91       XD_DEBUG_MESSAGE ("%s Assertion failure", __LINE__);              \
  92       xsignal1 (Qdbus_error, build_string ("Assertion failure"));       \
  93     }
  94
  95 #else /* !DBUS_DEBUG */
  96 #define XD_DEBUG_MESSAGE(...)           \
  97   if (!NILP (Vdbus_debug))              \
  98     {                                   \
  99       char s[1024];                     \
 100       sprintf (s, __VA_ARGS__);         \
 101       message ("%s: %s", __func__, s);  \
 102     }
 103 #define XD_DEBUG_VALID_LISP_OBJECT_P(object)
 104 #endif
 105
 106 /* Determine the DBusType of a given Lisp symbol.  OBJECT must be one
 107    of the predefined D-Bus type symbols.  */
 108 #define XD_LISP_SYMBOL_TO_DBUS_TYPE(object)                             \
 109   (EQ (object, QCdbus_type_byte)) ? DBUS_TYPE_BYTE                      \
 110   : (EQ (object, QCdbus_type_boolean)) ? DBUS_TYPE_BOOLEAN              \
 111   : (EQ (object, QCdbus_type_int16)) ? DBUS_TYPE_INT16                  \
 112   : (EQ (object, QCdbus_type_uint16)) ? DBUS_TYPE_UINT16                \
 113   : (EQ (object, QCdbus_type_int32)) ? DBUS_TYPE_INT32                  \
 114   : (EQ (object, QCdbus_type_uint32)) ? DBUS_TYPE_UINT32                \
 115   : (EQ (object, QCdbus_type_int64)) ? DBUS_TYPE_INT64                  \
 116   : (EQ (object, QCdbus_type_uint64)) ? DBUS_TYPE_UINT64                \
 117   : (EQ (object, QCdbus_type_double)) ? DBUS_TYPE_DOUBLE                \
 118   : (EQ (object, QCdbus_type_string)) ? DBUS_TYPE_STRING                \
 119   : (EQ (object, QCdbus_type_object_path)) ? DBUS_TYPE_OBJECT_PATH      \
 120   : (EQ (object, QCdbus_type_signature)) ? DBUS_TYPE_SIGNATURE          \
 121   : (EQ (object, QCdbus_type_array)) ? DBUS_TYPE_ARRAY                  \
 122   : (EQ (object, QCdbus_type_variant)) ? DBUS_TYPE_VARIANT              \
 123   : (EQ (object, QCdbus_type_struct)) ? DBUS_TYPE_STRUCT                \
 124   : (EQ (object, QCdbus_type_dict_entry)) ? DBUS_TYPE_DICT_ENTRY        \
 125   : DBUS_TYPE_INVALID
 126
 127 /* Determine the DBusType of a given Lisp OBJECT.  It is used to
 128    convert Lisp objects, being arguments of `dbus-call-method' or
 129    `dbus-send-signal', into corresponding C values appended as
 130    arguments to a D-Bus message.  */
 131 #define XD_LISP_OBJECT_TO_DBUS_TYPE(object)                             \
 132   (EQ (object, Qt) || EQ (object, Qnil)) ? DBUS_TYPE_BOOLEAN            \
 133   : (SYMBOLP (object)) ? XD_LISP_SYMBOL_TO_DBUS_TYPE (object)           \
 134   : (CONSP (object)) ? ((SYMBOLP (XCAR (object))                        \
 135                          && !EQ (XCAR (object), Qt)                     \
 136                          && !EQ (XCAR (object), Qnil))                  \
 137                         ? XD_LISP_SYMBOL_TO_DBUS_TYPE (XCAR (object))   \
 138                         : DBUS_TYPE_ARRAY)                              \
 139   : (NATNUMP (object)) ? DBUS_TYPE_UINT32                               \
 140   : (INTEGERP (object)) ? DBUS_TYPE_INT32                               \
 141   : (FLOATP (object)) ? DBUS_TYPE_DOUBLE                                \
 142   : (STRINGP (object)) ? DBUS_TYPE_STRING                               \
 143   : DBUS_TYPE_INVALID
 144
 145 /* Append C value, extracted from Lisp OBJECT, to iteration ITER.
 146    DTYPE must be a valid DBusType.  It is used to convert Lisp
 147    objects, being arguments of `dbus-call-method' or
 148    `dbus-send-signal', into corresponding C values appended as
 149    arguments to a D-Bus message.  */
 150 void
 151 xd_append_arg (dtype, object, iter)
 152      unsigned int dtype;
 153      DBusMessageIter *iter;
 154      Lisp_Object object;
 155 {
 156   char *value;
 157
 158   /* Check type of object.  If this has been detected implicitely, it
 159      is OK already, but there might be cases the type symbol and the
 160      corresponding object do'nt match.  */
 161   switch (dtype)
 162     {
 163     case DBUS_TYPE_BYTE:
 164     case DBUS_TYPE_UINT16:
 165     case DBUS_TYPE_UINT32:
 166     case DBUS_TYPE_UINT64:
 167       CHECK_NATNUM (object);
 168       break;
 169     case DBUS_TYPE_BOOLEAN:
 170       if (!EQ (object, Qt) && !EQ (object, Qnil))
 171         wrong_type_argument (intern ("booleanp"), object);
 172       break;
 173     case DBUS_TYPE_INT16:
 174     case DBUS_TYPE_INT32:
 175     case DBUS_TYPE_INT64:
 176       CHECK_NUMBER (object);
 177       break;
 178     case DBUS_TYPE_DOUBLE:
 179       CHECK_FLOAT (object);
 180       break;
 181     case DBUS_TYPE_STRING:
 182     case DBUS_TYPE_OBJECT_PATH:
 183     case DBUS_TYPE_SIGNATURE:
 184       CHECK_STRING (object);
 185       break;
 186     case DBUS_TYPE_ARRAY:
 187       CHECK_CONS (object);
 188       /* ToDo: Check that all list elements have the same type.  */
 189       break;
 190     case DBUS_TYPE_VARIANT:
 191       CHECK_CONS (object);
 192       /* ToDo: Check that there is exactly one element of basic type.  */
 193       break;
 194     case DBUS_TYPE_STRUCT:
 195      CHECK_CONS (object);
 196       break;
 197     case DBUS_TYPE_DICT_ENTRY:
 198       /* ToDo: Check that there are exactly two elements, and the
 199          first one is of basic type.  */
 200        CHECK_CONS (object);
 201       break;
 202     default:
 203       xsignal1 (Qdbus_error, build_string ("Unknown D-Bus type"));
 204     }
 205
 206   if (CONSP (object))
 207
 208     /* Compound types.  */
 209     {
 210       DBusMessageIter subiter;
 211       char subtype;
 212
 213       if (SYMBOLP (XCAR (object))
 214           && (strncmp (SDATA (XSYMBOL (XCAR (object))->xname), ":", 1) == 0))
 215         object = XCDR (object);
 216
 217       /* Open new subiteration.  */
 218       switch (dtype)
 219         {
 220         case DBUS_TYPE_ARRAY:
 221         case DBUS_TYPE_VARIANT:
 222           subtype = (char) XD_LISP_OBJECT_TO_DBUS_TYPE (XCAR (object));
 223           dbus_message_iter_open_container (iter, dtype, &subtype, &subiter);
 224           break;
 225         case DBUS_TYPE_STRUCT:
 226         case DBUS_TYPE_DICT_ENTRY:
 227           dbus_message_iter_open_container (iter, dtype, NULL, &subiter);
 228         }
 229
 230       /* Loop over list elements.  */
 231       while (!NILP (object))
 232         {
 233           dtype = XD_LISP_OBJECT_TO_DBUS_TYPE (XCAR (object));
 234           if (dtype == DBUS_TYPE_INVALID)
 235             xsignal2 (Qdbus_error,
 236                       build_string ("Not a valid argument"), XCAR (object));
 237
 238           if (SYMBOLP (XCAR (object))
 239               && (strncmp (SDATA (XSYMBOL (XCAR (object))->xname), ":", 1)
 240                   == 0))
 241             object = XCDR (object);
 242
 243           xd_append_arg (dtype, XCAR (object), &subiter);
 244
 245           object = XCDR (object);
 246         }
 247
 248       dbus_message_iter_close_container (iter, &subiter);
 249     }
 250
 251   else
 252
 253     /* Basic type.  */
 254     {
 255       switch (dtype)
 256         {
 257         case DBUS_TYPE_BYTE:
 258           XD_DEBUG_MESSAGE ("%d %u", dtype, XUINT (object));
 259           value = (unsigned char *) XUINT (object);
 260           break;
 261         case DBUS_TYPE_BOOLEAN:
 262           XD_DEBUG_MESSAGE ("%d %s", dtype, (NILP (object)) ? "false" : "true");
 263           value = (NILP (object))
 264             ? (unsigned char *) FALSE : (unsigned char *) TRUE;
 265           break;
 266         case DBUS_TYPE_INT16:
 267           XD_DEBUG_MESSAGE ("%d %d", dtype, XINT (object));
 268           value = (char *) (dbus_int16_t *) XINT (object);
 269           break;
 270         case DBUS_TYPE_UINT16:
 271           XD_DEBUG_MESSAGE ("%d %u", dtype, XUINT (object));
 272           value = (char *) (dbus_uint16_t *) XUINT (object);
 273           break;
 274         case DBUS_TYPE_INT32:
 275           XD_DEBUG_MESSAGE ("%d %d", dtype, XINT (object));
 276           value = (char *) (dbus_int32_t *) XINT (object);
 277           break;
 278         case DBUS_TYPE_UINT32:
 279           XD_DEBUG_MESSAGE ("%d %u", dtype, XUINT (object));
 280           value = (char *) (dbus_uint32_t *) XUINT (object);
 281           break;
 282         case DBUS_TYPE_INT64:
 283           XD_DEBUG_MESSAGE ("%d %d", dtype, XINT (object));
 284           value = (char *) (dbus_int64_t *) XINT (object);
 285           break;
 286         case DBUS_TYPE_UINT64:
 287           XD_DEBUG_MESSAGE ("%d %u", dtype, XUINT (object));
 288           value = (char *) (dbus_int64_t *) XUINT (object);
 289           break;
 290         case DBUS_TYPE_DOUBLE:
 291           XD_DEBUG_MESSAGE ("%d %f", dtype, XFLOAT (object));
 292           value = (char *) (float *) XFLOAT (object);
 293           break;
 294         case DBUS_TYPE_STRING:
 295         case DBUS_TYPE_OBJECT_PATH:
 296         case DBUS_TYPE_SIGNATURE:
 297           XD_DEBUG_MESSAGE ("%d %s", dtype, SDATA (object));
 298           value = SDATA (object);
 299           break;
 300         }
 301       if (!dbus_message_iter_append_basic (iter, dtype, &value))
 302         xsignal2 (Qdbus_error,
 303                   build_string ("Unable to append argument"), object);
 304     }
 305 }
 306
 307 /* Retrieve C value from a DBusMessageIter structure ITER, and return
 308    a converted Lisp object.  The type DTYPE of the argument of the
 309    D-Bus message must be a valid DBusType.  Compound D-Bus types are
 310    partly supported; they result always in a Lisp list.  */
 311 Lisp_Object
 312 xd_retrieve_arg (dtype, iter)
 313      unsigned int dtype;
 314      DBusMessageIter *iter;
 315 {
 316
 317   switch (dtype)
 318     {
 319     case DBUS_TYPE_BOOLEAN:
 320       {
 321         dbus_bool_t val;
 322         dbus_message_iter_get_basic (iter, &val);
 323         XD_DEBUG_MESSAGE ("%d %s", dtype, (val == FALSE) ? "false" : "true");
 324         return (val == FALSE) ? Qnil : Qt;
 325       }
 326     case DBUS_TYPE_INT32:
 327     case DBUS_TYPE_UINT32:
 328       {
 329         dbus_uint32_t val;
 330         dbus_message_iter_get_basic (iter, &val);
 331         XD_DEBUG_MESSAGE ("%d %d", dtype, val);
 332         return make_number (val);
 333       }
 334     case DBUS_TYPE_STRING:
 335     case DBUS_TYPE_OBJECT_PATH:
 336       {
 337         char *val;
 338         dbus_message_iter_get_basic (iter, &val);
 339         XD_DEBUG_MESSAGE ("%d %s", dtype, val);
 340         return build_string (val);
 341       }
 342     case DBUS_TYPE_ARRAY:
 343     case DBUS_TYPE_VARIANT:
 344     case DBUS_TYPE_STRUCT:
 345     case DBUS_TYPE_DICT_ENTRY:
 346       {
 347         Lisp_Object result;
 348         struct gcpro gcpro1;
 349         result = Qnil;
 350         GCPRO1 (result);
 351         DBusMessageIter subiter;
 352         int subtype;
 353         dbus_message_iter_recurse (iter, &subiter);
 354         while ((subtype = dbus_message_iter_get_arg_type (&subiter))
 355                != DBUS_TYPE_INVALID)
 356           {
 357             result = Fcons (xd_retrieve_arg (subtype, &subiter), result);
 358             dbus_message_iter_next (&subiter);
 359           }
 360         RETURN_UNGCPRO (Fnreverse (result));
 361       }
 362     default:
 363       XD_DEBUG_MESSAGE ("DBusType %d not supported", dtype);
 364       return Qnil;
 365     }
 366 }
 367
 368
 369 /* Initialize D-Bus connection.  BUS is a Lisp symbol, either :system
 370    or :session.  It tells which D-Bus to be initialized.  */
 371 DBusConnection *
 372 xd_initialize (bus)
 373      Lisp_Object bus;
 374 {
 375   DBusConnection *connection;
 376   DBusError derror;
 377
 378   /* Parameter check.  */
 379   CHECK_SYMBOL (bus);
 380   if (!((EQ (bus, QCdbus_system_bus)) || (EQ (bus, QCdbus_session_bus))))
 381     xsignal2 (Qdbus_error, build_string ("Wrong bus name"), bus);
 382
 383   /* Open a connection to the bus.  */
 384   dbus_error_init (&derror);
 385
 386   if (EQ (bus, QCdbus_system_bus))
 387     connection = dbus_bus_get (DBUS_BUS_SYSTEM, &derror);
 388   else
 389     connection = dbus_bus_get (DBUS_BUS_SESSION, &derror);
 390
 391   if (dbus_error_is_set (&derror))
 392     XD_ERROR (derror);
 393
 394   if (connection == NULL)
 395     xsignal2 (Qdbus_error, build_string ("No connection"), bus);
 396
 397   /* Return the result.  */
 398   return connection;
 399 }
 400
 401 DEFUN ("dbus-get-unique-name", Fdbus_get_unique_name, Sdbus_get_unique_name,
 402        1, 1, 0,
 403        doc: /* Return the unique name of Emacs registered at D-Bus BUS as string.  */)
 404      (bus)
 405      Lisp_Object bus;
 406 {
 407   DBusConnection *connection;
 408   char name[DBUS_MAXIMUM_NAME_LENGTH];
 409
 410   /* Check parameters.  */
 411   CHECK_SYMBOL (bus);
 412
 413   /* Open a connection to the bus.  */
 414   connection = xd_initialize (bus);
 415
 416   /* Request the name.  */
 417   strcpy (name, dbus_bus_get_unique_name (connection));
 418   if (name == NULL)
 419     xsignal1 (Qdbus_error, build_string ("No unique name available"));
 420
 421   /* Return.  */
 422   return build_string (name);
 423 }
 424
 425 DEFUN ("dbus-call-method", Fdbus_call_method, Sdbus_call_method, 5, MANY, 0,
 426        doc: /* Call METHOD on the D-Bus BUS.
 427
 428 BUS is either the symbol `:system' or the symbol `:session'.
 429
 430 SERVICE is the D-Bus service name to be used.  PATH is the D-Bus
 431 object path SERVICE is registered at.  INTERFACE is an interface
 432 offered by SERVICE.  It must provide METHOD.
 433
 434 All other arguments ARGS are passed to METHOD as arguments.  They are
 435 converted into D-Bus types via the following rules:
 436
 437   t and nil => DBUS_TYPE_BOOLEAN
 438   number    => DBUS_TYPE_UINT32
 439   integer   => DBUS_TYPE_INT32
 440   float     => DBUS_TYPE_DOUBLE
 441   string    => DBUS_TYPE_STRING
 442
 443 Other Lisp objects are not supported as input arguments of METHOD.
 444
 445 `dbus-call-method' returns the resulting values of METHOD as a list of
 446 Lisp objects.  The type conversion happens the other direction as for
 447 input arguments.  Additionally to the types supported for input
 448 arguments, the D-Bus compound types DBUS_TYPE_ARRAY, DBUS_TYPE_VARIANT,
 449 DBUS_TYPE_STRUCT and DBUS_TYPE_DICT_ENTRY are accepted.  All of them
 450 are converted into a list of Lisp objects which correspond to the
 451 elements of the D-Bus container.  Example:
 452
 453 \(dbus-call-method
 454   :session "org.gnome.seahorse" "/org/gnome/seahorse/keys/openpgp"
 455   "org.gnome.seahorse.Keys" "GetKeyField"
 456   "openpgp:657984B8C7A966DD" "simple-name")
 457
 458   => (t ("Philip R. Zimmermann"))
 459
 460 If the result of the METHOD call is just one value, the converted Lisp
 461 object is returned instead of a list containing this single Lisp object.
 462
 463 \(dbus-call-method
 464   :system "org.freedesktop.Hal" "/org/freedesktop/Hal/devices/computer"
 465   "org.freedesktop.Hal.Device" "GetPropertyString"
 466   "system.kernel.machine")
 467
 468   => "i686"
 469
 470 usage: (dbus-call-method BUS SERVICE PATH INTERFACE METHOD &rest ARGS)  */)
 471      (nargs, args)
 472      int nargs;
 473      register Lisp_Object *args;
 474 {
 475   Lisp_Object bus, service, path, interface, method;
 476   Lisp_Object result;
 477   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
 478   DBusConnection *connection;
 479   DBusMessage *dmessage;
 480   DBusMessage *reply;
 481   DBusMessageIter iter;
 482   DBusError derror;
 483   unsigned int dtype;
 484   int i;
 485   char *value;
 486
 487   /* Check parameters.  */
 488   bus = args[0];
 489   service = args[1];
 490   path = args[2];
 491   interface = args[3];
 492   method = args[4];
 493
 494   CHECK_SYMBOL (bus);
 495   CHECK_STRING (service);
 496   CHECK_STRING (path);
 497   CHECK_STRING (interface);
 498   CHECK_STRING (method);
 499   GCPRO5 (bus, service, path, interface, method);
 500
 501   XD_DEBUG_MESSAGE ("%s %s %s %s",
 502                     SDATA (service),
 503                     SDATA (path),
 504                     SDATA (interface),
 505                     SDATA (method));
 506
 507   /* Open a connection to the bus.  */
 508   connection = xd_initialize (bus);
 509
 510   /* Create the message.  */
 511   dmessage = dbus_message_new_method_call ((char *) SDATA (service),
 512                                            (char *) SDATA (path),
 513                                            (char *) SDATA (interface),
 514                                            (char *) SDATA (method));
 515   if (dmessage == NULL)
 516     {
 517       UNGCPRO;
 518       xsignal1 (Qdbus_error, build_string ("Unable to create a new message"));
 519     }
 520
 521   UNGCPRO;
 522
 523   /* Initialize parameter list of message.  */
 524   dbus_message_iter_init_append (dmessage, &iter);
 525
 526   /* Append parameters to the message.  */
 527   for (i = 5; i < nargs; ++i)
 528     {
 529
 530       XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
 531       XD_DEBUG_MESSAGE ("Parameter%d %s",
 532                         i-4,
 533                         SDATA (format2 ("%s", args[i], Qnil)));
 534
 535       dtype = XD_LISP_OBJECT_TO_DBUS_TYPE (args[i]);
 536       if (dtype == DBUS_TYPE_INVALID)
 537         xsignal2 (Qdbus_error, build_string ("Not a valid argument"), args[i]);
 538
 539       if (SYMBOLP (args[i])
 540           && (strncmp (SDATA (XSYMBOL (args[i])->xname), ":", 1) == 0))
 541         ++i;
 542
 543       xd_append_arg (dtype, args[i], &iter);
 544     }
 545
 546   /* Send the message.  */
 547   dbus_error_init (&derror);
 548   reply = dbus_connection_send_with_reply_and_block (connection,
 549                                                      dmessage,
 550                                                      -1,
 551                                                      &derror);
 552
 553   if (dbus_error_is_set (&derror))
 554     XD_ERROR (derror);
 555
 556   if (reply == NULL)
 557     xsignal1 (Qdbus_error, build_string ("No reply"));
 558
 559   XD_DEBUG_MESSAGE ("Message sent");
 560
 561   /* Collect the results.  */
 562   result = Qnil;
 563   GCPRO1 (result);
 564
 565   if (!dbus_message_iter_init (reply, &iter))
 566     {
 567       UNGCPRO;
 568       xsignal1 (Qdbus_error, build_string ("Cannot read reply"));
 569     }
 570
 571   /* Loop over the parameters of the D-Bus reply message.  Construct a
 572      Lisp list, which is returned by `dbus-call-method'.  */
 573   while ((dtype = dbus_message_iter_get_arg_type (&iter)) != DBUS_TYPE_INVALID)
 574     {
 575       result = Fcons (xd_retrieve_arg (dtype, &iter), result);
 576       dbus_message_iter_next (&iter);
 577     }
 578
 579   /* Cleanup.  */
 580   dbus_message_unref (dmessage);
 581   dbus_message_unref (reply);
 582
 583   /* Return the result.  If there is only one single Lisp object,
 584      return it as-it-is, otherwise return the reversed list.  */
 585   if (XUINT (Flength (result)) == 1)
 586     RETURN_UNGCPRO (XCAR (result));
 587   else
 588     RETURN_UNGCPRO (Fnreverse (result));
 589 }
 590
 591 DEFUN ("dbus-send-signal", Fdbus_send_signal, Sdbus_send_signal, 5, MANY, 0,
 592        doc: /* Send signal SIGNAL on the D-Bus BUS.
 593
 594 BUS is either the symbol `:system' or the symbol `:session'.
 595
 596 SERVICE is the D-Bus service name SIGNAL is sent from.  PATH is the
 597 D-Bus object path SERVICE is registered at.  INTERFACE is an interface
 598 offered by SERVICE.  It must provide signal SIGNAL.
 599
 600 All other arguments ARGS are passed to SIGNAL as arguments.  They are
 601 converted into D-Bus types via the following rules:
 602
 603   t and nil => DBUS_TYPE_BOOLEAN
 604   number    => DBUS_TYPE_UINT32
 605   integer   => DBUS_TYPE_INT32
 606   float     => DBUS_TYPE_DOUBLE
 607   string    => DBUS_TYPE_STRING
 608
 609 Other Lisp objects are not supported as arguments of SIGNAL.
 610
 611 Example:
 612
 613 \(dbus-send-signal
 614   :session "org.gnu.Emacs" "/org/gnu/Emacs"
 615   "org.gnu.Emacs.FileManager" "FileModified" "/home/albinus/.emacs")
 616
 617 usage: (dbus-send-signal BUS SERVICE PATH INTERFACE SIGNAL &rest ARGS)  */)
 618      (nargs, args)
 619      int nargs;
 620      register Lisp_Object *args;
 621 {
 622   Lisp_Object bus, service, path, interface, signal;
 623   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
 624   DBusConnection *connection;
 625   DBusMessage *dmessage;
 626   DBusMessageIter iter;
 627   unsigned int dtype;
 628   int i;
 629   char *value;
 630
 631   /* Check parameters.  */
 632   bus = args[0];
 633   service = args[1];
 634   path = args[2];
 635   interface = args[3];
 636   signal = args[4];
 637
 638   CHECK_SYMBOL (bus);
 639   CHECK_STRING (service);
 640   CHECK_STRING (path);
 641   CHECK_STRING (interface);
 642   CHECK_STRING (signal);
 643   GCPRO5 (bus, service, path, interface, signal);
 644
 645   XD_DEBUG_MESSAGE ("%s %s %s %s",
 646                     SDATA (service),
 647                     SDATA (path),
 648                     SDATA (interface),
 649                     SDATA (signal));
 650
 651   /* Open a connection to the bus.  */
 652   connection = xd_initialize (bus);
 653
 654   /* Create the message.  */
 655   dmessage = dbus_message_new_signal ((char *) SDATA (path),
 656                                       (char *) SDATA (interface),
 657                                       (char *) SDATA (signal));
 658   if (dmessage == NULL)
 659     {
 660       UNGCPRO;
 661       xsignal1 (Qdbus_error, build_string ("Unable to create a new message"));
 662     }
 663
 664   UNGCPRO;
 665
 666   /* Initialize parameter list of message.  */
 667   dbus_message_iter_init_append (dmessage, &iter);
 668
 669   /* Append parameters to the message.  */
 670   for (i = 5; i < nargs; ++i)
 671     {
 672       XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
 673       XD_DEBUG_MESSAGE ("Parameter%d %s",
 674                         i-4,
 675                         SDATA (format2 ("%s", args[i], Qnil)));
 676
 677       dtype = XD_LISP_OBJECT_TO_DBUS_TYPE (args[i]);
 678       if (dtype == DBUS_TYPE_INVALID)
 679         xsignal2 (Qdbus_error, build_string ("Not a valid argument"), args[i]);
 680
 681       if (SYMBOLP (args[i])
 682           && (strncmp (SDATA (XSYMBOL (args[i])->xname), ":", 1) == 0))
 683         ++i;
 684
 685       xd_append_arg (dtype, args[i], &iter);
 686     }
 687
 688   /* Send the message.  The message is just added to the outgoing
 689      message queue.  */
 690   if (!dbus_connection_send (connection, dmessage, NULL))
 691     xsignal1 (Qdbus_error, build_string ("Cannot send message"));
 692
 693   /* Flush connection to ensure the message is handled.  */
 694   dbus_connection_flush (connection);
 695
 696   XD_DEBUG_MESSAGE ("Signal sent");
 697
 698   /* Cleanup.  */
 699   dbus_message_unref (dmessage);
 700
 701   /* Return.  */
 702   return Qt;
 703 }
 704
 705 /* Read queued incoming message of the D-Bus BUS.  BUS is a Lisp
 706    symbol, either :system or :session.  */
 707 Lisp_Object
 708 xd_read_message (bus)
 709      Lisp_Object bus;
 710 {
 711   Lisp_Object args, key, value;
 712   struct gcpro gcpro1;
 713   static struct input_event event;
 714   DBusConnection *connection;
 715   DBusMessage *dmessage;
 716   DBusMessageIter iter;
 717   unsigned int dtype;
 718   char uname[DBUS_MAXIMUM_NAME_LENGTH];
 719   char path[DBUS_MAXIMUM_MATCH_RULE_LENGTH]; /* Unlimited in D-Bus spec.  */
 720   char interface[DBUS_MAXIMUM_NAME_LENGTH];
 721   char member[DBUS_MAXIMUM_NAME_LENGTH];
 722
 723   /* Open a connection to the bus.  */
 724   connection = xd_initialize (bus);
 725
 726   /* Non blocking read of the next available message.  */
 727   dbus_connection_read_write (connection, 0);
 728   dmessage = dbus_connection_pop_message (connection);
 729
 730   /* Return if there is no queued message.  */
 731   if (dmessage == NULL)
 732     return;
 733
 734   XD_DEBUG_MESSAGE ("Event received");
 735
 736   /* Collect the parameters.  */
 737   args = Qnil;
 738   GCPRO1 (args);
 739
 740   if (!dbus_message_iter_init (dmessage, &iter))
 741     {
 742       UNGCPRO;
 743       XD_DEBUG_MESSAGE ("Cannot read event");
 744       return;
 745     }
 746
 747   /* Loop over the resulting parameters.  Construct a list.  */
 748   while ((dtype = dbus_message_iter_get_arg_type (&iter)) != DBUS_TYPE_INVALID)
 749     {
 750       args = Fcons (xd_retrieve_arg (dtype, &iter), args);
 751       dbus_message_iter_next (&iter);
 752     }
 753
 754   /* The arguments are stored in reverse order.  Reorder them.  */
 755   args = Fnreverse (args);
 756
 757   /* Read unique name, object path, interface and member from the
 758      message.  */
 759   strcpy (uname,     dbus_message_get_sender (dmessage));
 760   strcpy (path,      dbus_message_get_path (dmessage));
 761   strcpy (interface, dbus_message_get_interface (dmessage));
 762   strcpy (member,    dbus_message_get_member (dmessage));
 763
 764   /* Search for a registered function of the message.  */
 765   key = list3 (bus, build_string (interface), build_string (member));
 766   value = Fgethash (key, Vdbus_registered_functions_table, Qnil);
 767
 768   /* Loop over the registered functions.  Construct an event.  */
 769   while (!NILP (value))
 770     {
 771       key = XCAR (value);
 772       /* key has the structure (UNAME SERVICE PATH HANDLER).  */
 773       if (((uname == NULL)
 774            || (NILP (XCAR (key)))
 775            || (strcmp (uname, SDATA (XCAR (key))) == 0))
 776           && ((path == NULL)
 777               || (NILP (XCAR (XCDR (XCDR (key)))))
 778               || (strcmp (path, SDATA (XCAR (XCDR (XCDR (key))))) == 0))
 779           && (!NILP (XCAR (XCDR (XCDR (XCDR (key)))))))
 780         {
 781           EVENT_INIT (event);
 782           event.kind = DBUS_EVENT;
 783           event.frame_or_window = Qnil;
 784           event.arg = Fcons (XCAR (XCDR (XCDR (XCDR (key)))), args);
 785
 786           /* Add uname, path, interface and member to the event.  */
 787           event.arg = Fcons ((member == NULL ? Qnil : build_string (member)),
 788                              event.arg);
 789           event.arg = Fcons ((interface == NULL
 790                               ? Qnil : build_string (interface)),
 791                              event.arg);
 792           event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
 793                              event.arg);
 794           event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
 795                              event.arg);
 796
 797           /* Add the bus symbol to the event.  */
 798           event.arg = Fcons (bus, event.arg);
 799
 800           /* Store it into the input event queue.  */
 801           kbd_buffer_store_event (&event);
 802         }
 803      value = XCDR (value);
 804     }
 805
 806   /* Cleanup.  */
 807   dbus_message_unref (dmessage);
 808   UNGCPRO;
 809 }
 810
 811 /* Read queued incoming messages from the system and session buses.  */
 812 void
 813 xd_read_queued_messages ()
 814 {
 815
 816   /* Vdbus_registered_functions_table will be initialized as hash
 817      table in dbus.el.  When this package isn't loaded yet, it doesn't
 818      make sense to handle D-Bus messages.  Furthermore, we ignore all
 819      Lisp errors during the call.  */
 820   if (HASH_TABLE_P (Vdbus_registered_functions_table))
 821     {
 822       internal_condition_case_1 (xd_read_message, QCdbus_system_bus,
 823                                  Qerror, Fidentity);
 824       internal_condition_case_1 (xd_read_message, QCdbus_session_bus,
 825                                  Qerror, Fidentity);
 826     }
 827 }
 828
 829 DEFUN ("dbus-register-signal", Fdbus_register_signal, Sdbus_register_signal,
 830        6, 6, 0,
 831        doc: /* Register for signal SIGNAL on the D-Bus BUS.
 832
 833 BUS is either the symbol `:system' or the symbol `:session'.
 834
 835 SERVICE is the D-Bus service name used by the sending D-Bus object.
 836 It can be either a known name or the unique name of the D-Bus object
 837 sending the signal.  When SERVICE is nil, related signals from all
 838 D-Bus objects shall be accepted.
 839
 840 PATH is the D-Bus object path SERVICE is registered.  It can also be
 841 nil if the path name of incoming signals shall not be checked.
 842
 843 INTERFACE is an interface offered by SERVICE.  It must provide SIGNAL.
 844 HANDLER is a Lisp function to be called when the signal is received.
 845 It must accept as arguments the values SIGNAL is sending.  INTERFACE,
 846 SIGNAL and HANDLER must not be nil.  Example:
 847
 848 \(defun my-signal-handler (device)
 849   (message "Device %s added" device))
 850
 851 \(dbus-register-signal
 852   :system "org.freedesktop.Hal" "/org/freedesktop/Hal/Manager"
 853   "org.freedesktop.Hal.Manager" "DeviceAdded" 'my-signal-handler)
 854
 855   => ((:system "org.freedesktop.Hal.Manager" "DeviceAdded")
 856       ("org.freedesktop.Hal" "/org/freedesktop/Hal/Manager" my-signal-handler))
 857
 858 `dbus-register-signal' returns an object, which can be used in
 859 `dbus-unregister-signal' for removing the registration.  */)
 860      (bus, service, path, interface, signal, handler)
 861      Lisp_Object bus, service, path, interface, signal, handler;
 862 {
 863   Lisp_Object uname, key, value;
 864   DBusConnection *connection;
 865   char rule[DBUS_MAXIMUM_MATCH_RULE_LENGTH];
 866   DBusError derror;
 867
 868   /* Check parameters.  */
 869   CHECK_SYMBOL (bus);
 870   if (!NILP (service)) CHECK_STRING (service);
 871   if (!NILP (path)) CHECK_STRING (path);
 872   CHECK_STRING (interface);
 873   CHECK_STRING (signal);
 874   FUNCTIONP (handler);
 875
 876   /* Retrieve unique name of service.  If service is a known name, we
 877      will register for the corresponding unique name, if any.  Signals
 878      are sent always with the unique name as sender.  Note: the unique
 879      name of "org.freedesktop.DBus" is that string itself.  */
 880   if ((!NILP (service))
 881       && (strlen (SDATA (service)) > 0)
 882       && (strcmp (SDATA (service), DBUS_SERVICE_DBUS) != 0)
 883       && (strncmp (SDATA (service), ":", 1) != 0))
 884     {
 885       uname = call2 (intern ("dbus-get-name-owner"), bus, service);
 886       /* When there is no unique name, we mark it with an empty
 887          string.  */
 888       if (NILP (uname))
 889         uname = build_string ("");
 890     }
 891   else
 892     uname = service;
 893
 894   /* Create a matching rule if the unique name exists (when no
 895      wildcard).  */
 896   if (NILP (uname) || (strlen (SDATA (uname)) > 0))
 897     {
 898       /* Open a connection to the bus.  */
 899       connection = xd_initialize (bus);
 900
 901       /* Create a rule to receive related signals.  */
 902       sprintf (rule,
 903                "type='signal',interface='%s',member='%s'",
 904                SDATA (interface),
 905                SDATA (signal));
 906
 907       /* Add unique name and path to the rule if they are non-nil.  */
 908       if (!NILP (uname))
 909         sprintf (rule, "%s,sender='%s'", rule, SDATA (uname));
 910
 911       if (!NILP (path))
 912         sprintf (rule, "%s,path='%s'", rule, SDATA (path));
 913
 914       /* Add the rule to the bus.  */
 915       dbus_error_init (&derror);
 916       dbus_bus_add_match (connection, rule, &derror);
 917       if (dbus_error_is_set (&derror))
 918         XD_ERROR (derror);
 919
 920       XD_DEBUG_MESSAGE ("Matching rule \"%s\" created", rule);
 921     }
 922
 923   /* Create a hash table entry.  */
 924   key = list3 (bus, interface, signal);
 925   value = Fgethash (key, Vdbus_registered_functions_table, Qnil);
 926
 927   if (NILP (Fmember (list4 (uname, service, path, handler), value)))
 928     Fputhash (key,
 929               Fcons (list4 (uname, service, path, handler), value),
 930               Vdbus_registered_functions_table);
 931
 932   /* Return object.  */
 933   return list2 (key, list3 (service, path, handler));
 934 }
 935
 936 DEFUN ("dbus-unregister-signal", Fdbus_unregister_signal, Sdbus_unregister_signal,
 937        1, 1, 0,
 938        doc: /* Unregister OBJECT from the D-Bus.
 939 OBJECT must be the result of a preceding `dbus-register-signal' call.  */)
 940      (object)
 941      Lisp_Object object;
 942 {
 943   Lisp_Object value;
 944   struct gcpro gcpro1;
 945
 946   /* Check parameter.  */
 947   CONSP (object) && (!NILP (XCAR (object))) && CONSP (XCDR (object));
 948
 949   /* Find the corresponding entry in the hash table.  */
 950   value = Fgethash (XCAR (object), Vdbus_registered_functions_table, Qnil);
 951
 952   /* Loop over the registered functions.  */
 953   while (!NILP (value))
 954     {
 955       GCPRO1 (value);
 956
 957       /* (car value) has the structure (UNAME SERVICE PATH HANDLER).
 958          (cdr object) has the structure ((SERVICE PATH HANDLER) ...).  */
 959       if (!NILP (Fequal (XCDR (XCAR (value)), XCAR (XCDR (object)))))
 960         {
 961           /* Compute new hash value.  */
 962           value = Fdelete (XCAR (value),
 963                            Fgethash (XCAR (object),
 964                                      Vdbus_registered_functions_table, Qnil));
 965           if (NILP (value))
 966             Fremhash (XCAR (object), Vdbus_registered_functions_table);
 967           else
 968             Fputhash (XCAR (object), value, Vdbus_registered_functions_table);
 969           RETURN_UNGCPRO (Qt);
 970         }
 971       UNGCPRO;
 972       value = XCDR (value);
 973     }
 974
 975   /* Return.  */
 976   return Qnil;
 977 }
 978
 979 \f
 980 void
 981 syms_of_dbusbind ()
 982 {
 983
 984   Qdbus_get_unique_name = intern ("dbus-get-unique-name");
 985   staticpro (&Qdbus_get_unique_name);
 986   defsubr (&Sdbus_get_unique_name);
 987
 988   Qdbus_call_method = intern ("dbus-call-method");
 989   staticpro (&Qdbus_call_method);
 990   defsubr (&Sdbus_call_method);
 991
 992   Qdbus_send_signal = intern ("dbus-send-signal");
 993   staticpro (&Qdbus_send_signal);
 994   defsubr (&Sdbus_send_signal);
 995
 996   Qdbus_register_signal = intern ("dbus-register-signal");
 997   staticpro (&Qdbus_register_signal);
 998   defsubr (&Sdbus_register_signal);
 999
1000   Qdbus_unregister_signal = intern ("dbus-unregister-signal");
1001   staticpro (&Qdbus_unregister_signal);
1002   defsubr (&Sdbus_unregister_signal);
1003
1004   Qdbus_error = intern ("dbus-error");
1005   staticpro (&Qdbus_error);
1006   Fput (Qdbus_error, Qerror_conditions,
1007         list2 (Qdbus_error, Qerror));
1008   Fput (Qdbus_error, Qerror_message,
1009         build_string ("D-Bus error"));
1010
1011   QCdbus_system_bus = intern (":system");
1012   staticpro (&QCdbus_system_bus);
1013
1014   QCdbus_session_bus = intern (":session");
1015   staticpro (&QCdbus_session_bus);
1016
1017   QCdbus_type_byte = intern (":byte");
1018   staticpro (&QCdbus_type_byte);
1019
1020   QCdbus_type_boolean = intern (":boolean");
1021   staticpro (&QCdbus_type_boolean);
1022
1023   QCdbus_type_int16 = intern (":int16");
1024   staticpro (&QCdbus_type_int16);
1025
1026   QCdbus_type_uint16 = intern (":uint16");
1027   staticpro (&QCdbus_type_uint16);
1028
1029   QCdbus_type_int32 = intern (":int32");
1030   staticpro (&QCdbus_type_int32);
1031
1032   QCdbus_type_uint32 = intern (":uint32");
1033   staticpro (&QCdbus_type_uint32);
1034
1035   QCdbus_type_int64 = intern (":int64");
1036   staticpro (&QCdbus_type_int64);
1037
1038   QCdbus_type_uint64 = intern (":uint64");
1039   staticpro (&QCdbus_type_uint64);
1040
1041   QCdbus_type_double = intern (":double");
1042   staticpro (&QCdbus_type_double);
1043
1044   QCdbus_type_string = intern (":string");
1045   staticpro (&QCdbus_type_string);
1046
1047   QCdbus_type_object_path = intern (":object-path");
1048   staticpro (&QCdbus_type_object_path);
1049
1050   QCdbus_type_signature = intern (":signature");
1051   staticpro (&QCdbus_type_signature);
1052
1053   QCdbus_type_array = intern (":array");
1054   staticpro (&QCdbus_type_array);
1055
1056   QCdbus_type_variant = intern (":variant");
1057   staticpro (&QCdbus_type_variant);
1058
1059   QCdbus_type_struct = intern (":struct");
1060   staticpro (&QCdbus_type_struct);
1061
1062   QCdbus_type_dict_entry = intern (":dict-entry");
1063   staticpro (&QCdbus_type_dict_entry);
1064
1065   DEFVAR_LISP ("dbus-registered-functions-table", &Vdbus_registered_functions_table,
1066     doc: /* Hash table of registered functions for D-Bus.
1067 The key in the hash table is the list (BUS INTERFACE MEMBER).  BUS is
1068 either the symbol `:system' or the symbol `:session'.  INTERFACE is a
1069 string which denotes a D-Bus interface, and MEMBER, also a string, is
1070 either a method or a signal INTERFACE is offering.  All arguments but
1071 BUS must not be nil.
1072
1073 The value in the hash table is a list of quadruple lists
1074 \((UNAME SERVICE PATH HANDLER) (UNAME SERVICE PATH HANDLER) ...).
1075 SERVICE is the service name as registered, UNAME is the corresponding
1076 unique name.  PATH is the object path of the sending object.  All of
1077 them can be nil, which means a wildcard then.  HANDLER is the function
1078 to be called when a D-Bus message, which matches the key criteria,
1079 arrives.  */);
1080   /* We initialize Vdbus_registered_functions_table in dbus.el,
1081      because we need to define a hash table function first.  */
1082   Vdbus_registered_functions_table = Qnil;
1083
1084   DEFVAR_LISP ("dbus-debug", &Vdbus_debug,
1085     doc: /* If non-nil, debug messages of D-Bus bindings are raised.  */);
1086 #ifdef DBUS_DEBUG
1087   Vdbus_debug = Qt;
1088 #else
1089   Vdbus_debug = Qnil;
1090 #endif
1091
1092   Fprovide (intern ("dbusbind"), Qnil);
1093
1094 }
1095
1096 #endif /* HAVE_DBUS */
1097
1098 /* arch-tag: 0e828477-b571-4fe4-b559-5c9211bc14b8
1099    (do not change this comment) */