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 <dbus/dbus.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_get_unique_name;
  34 Lisp_Object Qdbus_call_method;
  35 Lisp_Object Qdbus_send_signal;
  36 Lisp_Object Qdbus_register_signal;
  37 Lisp_Object Qdbus_unregister_signal;
  38
  39 /* D-Bus error symbol.  */
  40 Lisp_Object Qdbus_error;
  41
  42 /* Lisp symbols of the system and session buses.  */
  43 Lisp_Object QCdbus_system_bus, QCdbus_session_bus;
  44
  45 /* Hash table which keeps function definitions.  */
  46 Lisp_Object Vdbus_registered_functions_table;
  47
  48 /* Whether to debug D-Bus.  */
  49 Lisp_Object Vdbus_debug;
  50
  51 \f
  52 /* We use "xd_" and "XD_" as prefix for all internal symbols, because
  53    we don't want to poison other namespaces with "dbus_".  */
  54
  55 /* Raise a Lisp error from a D-Bus error.  */
  56 #define XD_ERROR(error)                                                 \
  57   {                                                                     \
  58     char s[1024];                                                       \
  59     strcpy (s, error.message);                                          \
  60     dbus_error_free (&error);                                           \
  61     /* Remove the trailing newline.  */                                 \
  62     if (strchr (s, '\n') != NULL)                                       \
  63       s[strlen (s) - 1] = '\0';                                         \
  64     xsignal1 (Qdbus_error, build_string (s));                           \
  65   }
  66
  67 /* Macros for debugging.  In order to enable them, build with
  68    "make MYCPPFLAGS='-DDBUS_DEBUG'".  */
  69 #ifdef DBUS_DEBUG
  70 #define XD_DEBUG_MESSAGE(...)           \
  71   {                                     \
  72     char s[1024];                       \
  73     sprintf (s, __VA_ARGS__);           \
  74     printf ("%s: %s\n", __func__, s);   \
  75     message ("%s: %s", __func__, s);    \
  76   }
  77 #define XD_DEBUG_VALID_LISP_OBJECT_P(object)                            \
  78   if (!valid_lisp_object_p (object))                                    \
  79     {                                                                   \
  80       XD_DEBUG_MESSAGE ("%s Assertion failure", __LINE__);              \
  81       xsignal1 (Qdbus_error, build_string ("Assertion failure"));       \
  82     }
  83
  84 #else /* !DBUS_DEBUG */
  85 #define XD_DEBUG_MESSAGE(...)           \
  86   if (!NILP (Vdbus_debug))              \
  87     {                                   \
  88       char s[1024];                     \
  89       sprintf (s, __VA_ARGS__);         \
  90       message ("%s: %s", __func__, s);  \
  91     }
  92 #define XD_DEBUG_VALID_LISP_OBJECT_P(object)
  93 #endif
  94
  95 /* Determine the DBusType of a given Lisp object.  It is used to
  96    convert Lisp objects, being arguments of `dbus-call-method' or
  97    `dbus-send-signal', into corresponding C values appended as
  98    arguments to a D-Bus message.  */
  99 #define XD_LISP_OBJECT_TO_DBUS_TYPE(object)                             \
 100   (EQ (object, Qt) || EQ (object, Qnil)) ? DBUS_TYPE_BOOLEAN :          \
 101   (NATNUMP (object)) ? DBUS_TYPE_UINT32 :                               \
 102   (INTEGERP (object)) ? DBUS_TYPE_INT32 :                               \
 103   (FLOATP (object)) ? DBUS_TYPE_DOUBLE :                                \
 104   (STRINGP (object)) ? DBUS_TYPE_STRING :                               \
 105   DBUS_TYPE_INVALID
 106
 107 /* Extract C value from Lisp OBJECT.  DTYPE must be a valid DBusType,
 108    as detected by XD_LISP_OBJECT_TO_DBUS_TYPE.  Compound types are not
 109    supported (yet).  It is used to convert Lisp objects, being
 110    arguments of `dbus-call-method' or `dbus-send-signal', into
 111    corresponding C values appended as arguments to a D-Bus
 112    message.  */
 113 char *
 114 xd_retrieve_value (dtype, object)
 115      uint dtype;
 116      Lisp_Object object;
 117 {
 118
 119   XD_DEBUG_VALID_LISP_OBJECT_P (object);
 120   switch (dtype)
 121     {
 122     case DBUS_TYPE_BOOLEAN:
 123       XD_DEBUG_MESSAGE ("%d %s", dtype, (NILP (object)) ? "false" : "true");
 124       return (NILP (object)) ? (char *) FALSE : (char *) TRUE;
 125     case DBUS_TYPE_UINT32:
 126       XD_DEBUG_MESSAGE ("%d %d", dtype, XUINT (object));
 127       return (char *) XUINT (object);
 128     case DBUS_TYPE_INT32:
 129       XD_DEBUG_MESSAGE ("%d %d", dtype, XINT (object));
 130       return (char *) XINT (object);
 131     case DBUS_TYPE_DOUBLE:
 132       XD_DEBUG_MESSAGE ("%d %d", dtype, XFLOAT (object));
 133       return (char *) XFLOAT (object);
 134     case DBUS_TYPE_STRING:
 135       XD_DEBUG_MESSAGE ("%d %s", dtype, SDATA (object));
 136       return SDATA (object);
 137     default:
 138       XD_DEBUG_MESSAGE ("DBus-Type %d not supported", dtype);
 139       return NULL;
 140     }
 141 }
 142
 143 /* Retrieve C value from a DBusMessageIter structure ITER, and return
 144    a converted Lisp object.  The type DTYPE of the argument of the
 145    D-Bus message must be a valid DBusType.  Compound D-Bus types are
 146    partly supported; they result always in a Lisp list.  */
 147 Lisp_Object
 148 xd_retrieve_arg (dtype, iter)
 149      uint dtype;
 150      DBusMessageIter *iter;
 151 {
 152
 153   switch (dtype)
 154     {
 155     case DBUS_TYPE_BOOLEAN:
 156       {
 157         dbus_bool_t val;
 158         dbus_message_iter_get_basic (iter, &val);
 159         XD_DEBUG_MESSAGE ("%d %s", dtype, (val == FALSE) ? "false" : "true");
 160         return (val == FALSE) ? Qnil : Qt;
 161       }
 162     case DBUS_TYPE_INT32:
 163     case DBUS_TYPE_UINT32:
 164       {
 165         dbus_uint32_t val;
 166         dbus_message_iter_get_basic (iter, &val);
 167         XD_DEBUG_MESSAGE ("%d %d", dtype, val);
 168         return make_number (val);
 169       }
 170     case DBUS_TYPE_STRING:
 171     case DBUS_TYPE_OBJECT_PATH:
 172       {
 173         char *val;
 174         dbus_message_iter_get_basic (iter, &val);
 175         XD_DEBUG_MESSAGE ("%d %s", dtype, val);
 176         return build_string (val);
 177       }
 178     case DBUS_TYPE_ARRAY:
 179     case DBUS_TYPE_VARIANT:
 180     case DBUS_TYPE_STRUCT:
 181     case DBUS_TYPE_DICT_ENTRY:
 182       {
 183         Lisp_Object result;
 184         struct gcpro gcpro1;
 185         result = Qnil;
 186         GCPRO1 (result);
 187         DBusMessageIter subiter;
 188         int subtype;
 189         dbus_message_iter_recurse (iter, &subiter);
 190         while ((subtype = dbus_message_iter_get_arg_type (&subiter))
 191                != DBUS_TYPE_INVALID)
 192           {
 193             result = Fcons (xd_retrieve_arg (subtype, &subiter), result);
 194             dbus_message_iter_next (&subiter);
 195           }
 196         RETURN_UNGCPRO (Fnreverse (result));
 197       }
 198     default:
 199       XD_DEBUG_MESSAGE ("DBusType %d not supported", dtype);
 200       return Qnil;
 201     }
 202 }
 203
 204
 205 /* Initialize D-Bus connection.  BUS is a Lisp symbol, either :system
 206    or :session.  It tells which D-Bus to be initialized.  */
 207 DBusConnection *
 208 xd_initialize (bus)
 209      Lisp_Object bus;
 210 {
 211   DBusConnection *connection;
 212   DBusError derror;
 213
 214   /* Parameter check.  */
 215   CHECK_SYMBOL (bus);
 216   if (!((EQ (bus, QCdbus_system_bus)) || (EQ (bus, QCdbus_session_bus))))
 217     xsignal2 (Qdbus_error, build_string ("Wrong bus name"), bus);
 218
 219   /* Open a connection to the bus.  */
 220   dbus_error_init (&derror);
 221
 222   if (EQ (bus, QCdbus_system_bus))
 223     connection = dbus_bus_get (DBUS_BUS_SYSTEM, &derror);
 224   else
 225     connection = dbus_bus_get (DBUS_BUS_SESSION, &derror);
 226
 227   if (dbus_error_is_set (&derror))
 228     XD_ERROR (derror);
 229
 230   if (connection == NULL)
 231     xsignal2 (Qdbus_error, build_string ("No connection"), bus);
 232
 233   /* Return the result.  */
 234   return connection;
 235 }
 236
 237 DEFUN ("dbus-get-unique-name", Fdbus_get_unique_name, Sdbus_get_unique_name,
 238        1, 1, 0,
 239        doc: /* Return the unique name of Emacs registered at D-Bus BUS as string.  */)
 240      (bus)
 241      Lisp_Object bus;
 242 {
 243   DBusConnection *connection;
 244   char name[DBUS_MAXIMUM_NAME_LENGTH];
 245
 246   /* Check parameters.  */
 247   CHECK_SYMBOL (bus);
 248
 249   /* Open a connection to the bus.  */
 250   connection = xd_initialize (bus);
 251
 252   /* Request the name.  */
 253   strcpy (name, dbus_bus_get_unique_name (connection));
 254   if (name == NULL)
 255     xsignal1 (Qdbus_error, build_string ("No unique name available"));
 256
 257   /* Return.  */
 258   return build_string (name);
 259 }
 260
 261 DEFUN ("dbus-call-method", Fdbus_call_method, Sdbus_call_method, 5, MANY, 0,
 262        doc: /* Call METHOD on the D-Bus BUS.
 263
 264 BUS is either the symbol `:system' or the symbol `:session'.
 265
 266 SERVICE is the D-Bus service name to be used.  PATH is the D-Bus
 267 object path SERVICE is registered at.  INTERFACE is an interface
 268 offered by SERVICE.  It must provide METHOD.
 269
 270 All other arguments ARGS are passed to METHOD as arguments.  They are
 271 converted into D-Bus types via the following rules:
 272
 273   t and nil => DBUS_TYPE_BOOLEAN
 274   number    => DBUS_TYPE_UINT32
 275   integer   => DBUS_TYPE_INT32
 276   float     => DBUS_TYPE_DOUBLE
 277   string    => DBUS_TYPE_STRING
 278
 279 Other Lisp objects are not supported as input arguments of METHOD.
 280
 281 `dbus-call-method' returns the resulting values of METHOD as a list of
 282 Lisp objects.  The type conversion happens the other direction as for
 283 input arguments.  Additionally to the types supported for input
 284 arguments, the D-Bus compound types DBUS_TYPE_ARRAY, DBUS_TYPE_VARIANT,
 285 DBUS_TYPE_STRUCT and DBUS_TYPE_DICT_ENTRY are accepted.  All of them
 286 are converted into a list of Lisp objects which correspond to the
 287 elements of the D-Bus container.  Example:
 288
 289 \(dbus-call-method
 290   :session "org.gnome.seahorse" "/org/gnome/seahorse/keys/openpgp"
 291   "org.gnome.seahorse.Keys" "GetKeyField"
 292   "openpgp:657984B8C7A966DD" "simple-name")
 293
 294   => (t ("Philip R. Zimmermann"))
 295
 296 If the result of the METHOD call is just one value, the converted Lisp
 297 object is returned instead of a list containing this single Lisp object.
 298
 299 \(dbus-call-method
 300   :system "org.freedesktop.Hal" "/org/freedesktop/Hal/devices/computer"
 301   "org.freedesktop.Hal.Device" "GetPropertyString"
 302   "system.kernel.machine")
 303
 304   => "i686"
 305
 306 usage: (dbus-call-method BUS SERVICE PATH INTERFACE METHOD &rest ARGS)  */)
 307      (nargs, args)
 308      int nargs;
 309      register Lisp_Object *args;
 310 {
 311   Lisp_Object bus, service, path, interface, method;
 312   Lisp_Object result;
 313   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
 314   DBusConnection *connection;
 315   DBusMessage *dmessage;
 316   DBusMessage *reply;
 317   DBusMessageIter iter;
 318   DBusError derror;
 319   uint dtype;
 320   int i;
 321   char *value;
 322
 323   /* Check parameters.  */
 324   bus = args[0];
 325   service = args[1];
 326   path = args[2];
 327   interface = args[3];
 328   method = args[4];
 329
 330   CHECK_SYMBOL (bus);
 331   CHECK_STRING (service);
 332   CHECK_STRING (path);
 333   CHECK_STRING (interface);
 334   CHECK_STRING (method);
 335   GCPRO5 (bus, service, path, interface, method);
 336
 337   XD_DEBUG_MESSAGE ("%s %s %s %s",
 338                     SDATA (service),
 339                     SDATA (path),
 340                     SDATA (interface),
 341                     SDATA (method));
 342
 343   /* Open a connection to the bus.  */
 344   connection = xd_initialize (bus);
 345
 346   /* Create the message.  */
 347   dmessage = dbus_message_new_method_call (SDATA (service),
 348                                            SDATA (path),
 349                                            SDATA (interface),
 350                                            SDATA (method));
 351   if (dmessage == NULL)
 352     {
 353       UNGCPRO;
 354       xsignal1 (Qdbus_error, build_string ("Unable to create a new message"));
 355     }
 356
 357   UNGCPRO;
 358
 359   /* Append parameters to the message.  */
 360   for (i = 5; i < nargs; ++i)
 361     {
 362
 363       XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
 364       XD_DEBUG_MESSAGE ("Parameter%d %s",
 365                         i-4,
 366                         SDATA (format2 ("%s", args[i], Qnil)));
 367
 368       dtype = XD_LISP_OBJECT_TO_DBUS_TYPE (args[i]);
 369       if (dtype == DBUS_TYPE_INVALID)
 370         xsignal2 (Qdbus_error, build_string ("Not a valid argument"), args[i]);
 371
 372       value = (char *) xd_retrieve_value (dtype, args[i]);
 373
 374       if (!dbus_message_append_args (dmessage,
 375                                      dtype,
 376                                      &value,
 377                                      DBUS_TYPE_INVALID))
 378         xsignal2 (Qdbus_error,
 379                   build_string ("Unable to append argument"), args[i]);
 380     }
 381
 382   /* Send the message.  */
 383   dbus_error_init (&derror);
 384   reply = dbus_connection_send_with_reply_and_block (connection,
 385                                                      dmessage,
 386                                                      -1,
 387                                                      &derror);
 388
 389   if (dbus_error_is_set (&derror))
 390     XD_ERROR (derror);
 391
 392   if (reply == NULL)
 393     xsignal1 (Qdbus_error, build_string ("No reply"));
 394
 395   XD_DEBUG_MESSAGE ("Message sent");
 396
 397   /* Collect the results.  */
 398   result = Qnil;
 399   GCPRO1 (result);
 400
 401   if (!dbus_message_iter_init (reply, &iter))
 402     {
 403       UNGCPRO;
 404       xsignal1 (Qdbus_error, build_string ("Cannot read reply"));
 405     }
 406
 407   /* Loop over the parameters of the D-Bus reply message.  Construct a
 408      Lisp list, which is returned by `dbus-call-method'.  */
 409   while ((dtype = dbus_message_iter_get_arg_type (&iter)) != DBUS_TYPE_INVALID)
 410     {
 411       result = Fcons (xd_retrieve_arg (dtype, &iter), result);
 412       dbus_message_iter_next (&iter);
 413     }
 414
 415   /* Cleanup.  */
 416   dbus_message_unref (dmessage);
 417   dbus_message_unref (reply);
 418
 419   /* Return the result.  If there is only one single Lisp object,
 420      return it as-it-is, otherwise return the reversed list.  */
 421   if (XUINT (Flength (result)) == 1)
 422     RETURN_UNGCPRO (XCAR (result));
 423   else
 424     RETURN_UNGCPRO (Fnreverse (result));
 425 }
 426
 427 DEFUN ("dbus-send-signal", Fdbus_send_signal, Sdbus_send_signal, 5, MANY, 0,
 428        doc: /* Send signal SIGNAL on the D-Bus BUS.
 429
 430 BUS is either the symbol `:system' or the symbol `:session'.
 431
 432 SERVICE is the D-Bus service name SIGNAL is sent from.  PATH is the
 433 D-Bus object path SERVICE is registered at.  INTERFACE is an interface
 434 offered by SERVICE.  It must provide signal SIGNAL.
 435
 436 All other arguments ARGS are passed to SIGNAL as arguments.  They are
 437 converted into D-Bus types via the following rules:
 438
 439   t and nil => DBUS_TYPE_BOOLEAN
 440   number    => DBUS_TYPE_UINT32
 441   integer   => DBUS_TYPE_INT32
 442   float     => DBUS_TYPE_DOUBLE
 443   string    => DBUS_TYPE_STRING
 444
 445 Other Lisp objects are not supported as arguments of SIGNAL.
 446
 447 Example:
 448
 449 \(dbus-send-signal
 450   :session "org.gnu.Emacs" "/org/gnu/Emacs"
 451   "org.gnu.Emacs.FileManager" "FileModified" "/home/albinus/.emacs")
 452
 453 usage: (dbus-send-signal BUS SERVICE PATH INTERFACE SIGNAL &rest ARGS)  */)
 454      (nargs, args)
 455      int nargs;
 456      register Lisp_Object *args;
 457 {
 458   Lisp_Object bus, service, path, interface, signal;
 459   struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
 460   DBusConnection *connection;
 461   DBusMessage *dmessage;
 462   uint dtype;
 463   int i;
 464   char *value;
 465
 466   /* Check parameters.  */
 467   bus = args[0];
 468   service = args[1];
 469   path = args[2];
 470   interface = args[3];
 471   signal = args[4];
 472
 473   CHECK_SYMBOL (bus);
 474   CHECK_STRING (service);
 475   CHECK_STRING (path);
 476   CHECK_STRING (interface);
 477   CHECK_STRING (signal);
 478   GCPRO5 (bus, service, path, interface, signal);
 479
 480   XD_DEBUG_MESSAGE ("%s %s %s %s",
 481                     SDATA (service),
 482                     SDATA (path),
 483                     SDATA (interface),
 484                     SDATA (signal));
 485
 486   /* Open a connection to the bus.  */
 487   connection = xd_initialize (bus);
 488
 489   /* Create the message.  */
 490   dmessage = dbus_message_new_signal (SDATA (path),
 491                                       SDATA (interface),
 492                                       SDATA (signal));
 493   if (dmessage == NULL)
 494     {
 495       UNGCPRO;
 496       xsignal1 (Qdbus_error, build_string ("Unable to create a new message"));
 497     }
 498
 499   UNGCPRO;
 500
 501   /* Append parameters to the message.  */
 502   for (i = 5; i < nargs; ++i)
 503     {
 504       XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
 505       XD_DEBUG_MESSAGE ("Parameter%d %s",
 506                         i-4,
 507                         SDATA (format2 ("%s", args[i], Qnil)));
 508
 509       dtype = XD_LISP_OBJECT_TO_DBUS_TYPE (args[i]);
 510       if (dtype == DBUS_TYPE_INVALID)
 511         xsignal2 (Qdbus_error, build_string ("Not a valid argument"), args[i]);
 512
 513       value = (char *) xd_retrieve_value (dtype, args[i]);
 514
 515       if (!dbus_message_append_args (dmessage,
 516                                      dtype,
 517                                      &value,
 518                                      DBUS_TYPE_INVALID))
 519         xsignal2 (Qdbus_error,
 520                   build_string ("Unable to append argument"), args[i]);
 521     }
 522
 523   /* Send the message.  The message is just added to the outgoing
 524      message queue.  */
 525   if (!dbus_connection_send (connection, dmessage, NULL))
 526     xsignal1 (Qdbus_error, build_string ("Cannot send message"));
 527
 528   /* Flush connection to ensure the message is handled.  */
 529   dbus_connection_flush (connection);
 530
 531   XD_DEBUG_MESSAGE ("Signal sent");
 532
 533   /* Cleanup.  */
 534   dbus_message_unref (dmessage);
 535
 536   /* Return.  */
 537   return Qt;
 538 }
 539
 540 /* Read queued incoming message of the D-Bus BUS.  BUS is a Lisp
 541    symbol, either :system or :session.  */
 542 Lisp_Object
 543 xd_read_message (bus)
 544      Lisp_Object bus;
 545 {
 546   Lisp_Object args, key, value;
 547   struct gcpro gcpro1;
 548   static struct input_event event;
 549   DBusConnection *connection;
 550   DBusMessage *dmessage;
 551   DBusMessageIter iter;
 552   uint dtype;
 553   char uname[DBUS_MAXIMUM_NAME_LENGTH];
 554   char path[DBUS_MAXIMUM_MATCH_RULE_LENGTH]; /* Unlimited in D-Bus spec.  */
 555   char interface[DBUS_MAXIMUM_NAME_LENGTH];
 556   char member[DBUS_MAXIMUM_NAME_LENGTH];
 557
 558   /* Open a connection to the bus.  */
 559   connection = xd_initialize (bus);
 560
 561   /* Non blocking read of the next available message.  */
 562   dbus_connection_read_write (connection, 0);
 563   dmessage = dbus_connection_pop_message (connection);
 564
 565   /* Return if there is no queued message.  */
 566   if (dmessage == NULL)
 567     return;
 568
 569   XD_DEBUG_MESSAGE ("Event received");
 570
 571   /* Collect the parameters.  */
 572   args = Qnil;
 573   GCPRO1 (args);
 574
 575   if (!dbus_message_iter_init (dmessage, &iter))
 576     {
 577       UNGCPRO;
 578       XD_DEBUG_MESSAGE ("Cannot read event");
 579       return;
 580     }
 581
 582   /* Loop over the resulting parameters.  Construct a list.  */
 583   while ((dtype = dbus_message_iter_get_arg_type (&iter)) != DBUS_TYPE_INVALID)
 584     {
 585       args = Fcons (xd_retrieve_arg (dtype, &iter), args);
 586       dbus_message_iter_next (&iter);
 587     }
 588
 589   /* The arguments are stored in reverse order.  Reorder them.  */
 590   args = Fnreverse (args);
 591
 592   /* Read unique name, object path, interface and member from the
 593      message.  */
 594   strcpy (uname,     dbus_message_get_sender (dmessage));
 595   strcpy (path,      dbus_message_get_path (dmessage));
 596   strcpy (interface, dbus_message_get_interface (dmessage));
 597   strcpy (member,    dbus_message_get_member (dmessage));
 598
 599   /* Search for a registered function of the message.  */
 600   key = list3 (bus, build_string (interface), build_string (member));
 601   value = Fgethash (key, Vdbus_registered_functions_table, Qnil);
 602
 603   /* Loop over the registered functions.  Construct an event.  */
 604   while (!NILP (value))
 605     {
 606       key = XCAR (value);
 607       /* key has the structure (SERVICE UNAME PATH HANDLER).  */
 608       if (((uname == NULL) || (NILP (XCAR (XCDR (key)))) ||
 609            (strcmp (uname, SDATA (XCAR (XCDR (key)))) == 0)) &&
 610           ((path == NULL) || (NILP (XCAR (XCDR (XCDR (key))))) ||
 611            (strcmp (path, SDATA (XCAR (XCDR (XCDR (key))))) == 0)) &&
 612           (!NILP (XCAR (XCDR (XCDR (XCDR (key)))))))
 613         {
 614           EVENT_INIT (event);
 615           event.kind = DBUS_EVENT;
 616           event.frame_or_window = Qnil;
 617           event.arg = Fcons (XCAR (XCDR (XCDR (XCDR (key)))), args);
 618
 619           /* Add uname, path, interface and member to the event.  */
 620           event.arg = Fcons ((member == NULL ? Qnil : build_string (member)),
 621                              event.arg);
 622           event.arg = Fcons ((interface == NULL
 623                               ? Qnil : build_string (interface)),
 624                              event.arg);
 625           event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
 626                              event.arg);
 627           event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
 628                              event.arg);
 629
 630           /* Add the bus symbol to the event.  */
 631           event.arg = Fcons (bus, event.arg);
 632
 633           /* Store it into the input event queue.  */
 634           kbd_buffer_store_event (&event);
 635         }
 636      value = XCDR (value);
 637     }
 638
 639   /* Cleanup.  */
 640   dbus_message_unref (dmessage);
 641   UNGCPRO;
 642 }
 643
 644 /* Read queued incoming messages from the system and session buses.  */
 645 void
 646 xd_read_queued_messages ()
 647 {
 648
 649   /* Vdbus_registered_functions_table will be made as hash table in
 650      dbus.el.  When it isn't loaded yet, it doesn't make sense to
 651      handle D-Bus messages.  Furthermore, we ignore all Lisp errors
 652      during the call.  */
 653   if (HASH_TABLE_P (Vdbus_registered_functions_table))
 654     {
 655       internal_condition_case_1 (xd_read_message, QCdbus_system_bus,
 656                                  Qerror, Fidentity);
 657       internal_condition_case_1 (xd_read_message, QCdbus_session_bus,
 658                                  Qerror, Fidentity);
 659     }
 660 }
 661
 662 DEFUN ("dbus-register-signal", Fdbus_register_signal, Sdbus_register_signal,
 663        6, 6, 0,
 664        doc: /* Register for signal SIGNAL on the D-Bus BUS.
 665
 666 BUS is either the symbol `:system' or the symbol `:session'.
 667
 668 SERVICE is the D-Bus service name used by the sending D-Bus object.
 669 It can be either a known name or the unique name of the D-Bus object
 670 sending the signal.  When SERVICE is nil, related signals from all
 671 D-Bus objects shall be accepted.
 672
 673 PATH is the D-Bus object path SERVICE is registered.  It can also be
 674 nil if the path name of incoming signals shall not be checked.
 675
 676 INTERFACE is an interface offered by SERVICE.  It must provide SIGNAL.
 677 HANDLER is a Lisp function to be called when the signal is received.
 678 It must accept as arguments the values SIGNAL is sending.  INTERFACE,
 679 SIGNAL and HANDLER must not be nil.  Example:
 680
 681 \(defun my-signal-handler (device)
 682   (message "Device %s added" device))
 683
 684 \(dbus-register-signal
 685   :system "org.freedesktop.Hal" "/org/freedesktop/Hal/Manager"
 686   "org.freedesktop.Hal.Manager" "DeviceAdded" 'my-signal-handler)
 687
 688   => (:system ":1.3" "/org/freedesktop/Hal/Manager"
 689       "org.freedesktop.Hal.Manager" "DeviceAdded")
 690
 691 `dbus-register-signal' returns an object, which can be used in
 692 `dbus-unregister-signal' for removing the registration.  */)
 693      (bus, service, path, interface, signal, handler)
 694      Lisp_Object bus, service, path, interface, signal, handler;
 695 {
 696   Lisp_Object unique_name, key, value;
 697   DBusConnection *connection;
 698   char rule[DBUS_MAXIMUM_MATCH_RULE_LENGTH];
 699   DBusError derror;
 700
 701   /* Check parameters.  */
 702   CHECK_SYMBOL (bus);
 703   if (!NILP (service)) CHECK_STRING (service);
 704   if (!NILP (path)) CHECK_STRING (path);
 705   CHECK_STRING (interface);
 706   CHECK_STRING (signal);
 707   CHECK_SYMBOL (handler);
 708
 709   /* Retrieve unique name of service.  If service is a known name, we
 710      will register for the corresponding unique name, if any.  Signals
 711      are sent always with the unique name as sender.  Note: the unique
 712      name of "org.freedesktop.DBus" is that string itself.  */
 713   if ((!NILP (service)) &&
 714       (strlen (SDATA (service)) > 0) &&
 715       (strcmp (SDATA (service), DBUS_SERVICE_DBUS) != 0) &&
 716       (strncmp (SDATA (service), ":", 1) != 0))
 717     unique_name = call2 (intern ("dbus-get-name-owner"), bus, service);
 718   else
 719     unique_name = service;
 720
 721   /* Open a connection to the bus.  */
 722   connection = xd_initialize (bus);
 723
 724   /* Create a rule to receive related signals.  */
 725   sprintf (rule,
 726            "type='signal',interface='%s',member=%s%",
 727            SDATA (interface),
 728            SDATA (signal));
 729
 730   /* Add unique name and path to the rule if they are non-nil.  */
 731   if (!NILP (unique_name))
 732     sprintf (rule, "%s,sender='%s'%", rule, SDATA (unique_name));
 733
 734   if (!NILP (path))
 735     sprintf (rule, "%s,path='%s'", rule, SDATA (path));
 736
 737   /* Add the rule to the bus.  */
 738   dbus_error_init (&derror);
 739   dbus_bus_add_match (connection, rule, &derror);
 740   if (dbus_error_is_set (&derror))
 741     XD_ERROR (derror);
 742
 743   XD_DEBUG_MESSAGE ("Matching rule \"%s\" created", rule);
 744
 745   /* Create a hash table entry.  */
 746   key = list3 (bus, interface, signal);
 747   value = Fgethash (key, Vdbus_registered_functions_table, Qnil);
 748
 749   if (NILP (Fmember (list4 (service, unique_name, path, handler), value)))
 750     Fputhash (key,
 751               Fcons (list4 (service, unique_name, path, handler), value),
 752               Vdbus_registered_functions_table);
 753
 754   /* Return key.  */
 755   return key;
 756 }
 757
 758 /* The current implementation removes ALL registered functions for a
 759    given signal.  Shouldn't be a problem in general, but there might
 760    be cases it is not desired.  Maybe we can refine the
 761    implementation.  */
 762 DEFUN ("dbus-unregister-signal", Fdbus_unregister_signal, Sdbus_unregister_signal,
 763        1, 1, 0,
 764        doc: /* Unregister OBJECT from the D-Bus.
 765 OBJECT must be the result of a preceding `dbus-register-signal' call.  */)
 766      (object)
 767      Lisp_Object object;
 768 {
 769
 770   /* Unintern the signal symbol.  */
 771   Fremhash (object, Vdbus_registered_functions_table);
 772
 773   /* Return.  */
 774   return Qnil;
 775 }
 776
 777 \f
 778 void
 779 syms_of_dbusbind ()
 780 {
 781
 782   Qdbus_get_unique_name = intern ("dbus-get-unique-name");
 783   staticpro (&Qdbus_get_unique_name);
 784   defsubr (&Sdbus_get_unique_name);
 785
 786   Qdbus_call_method = intern ("dbus-call-method");
 787   staticpro (&Qdbus_call_method);
 788   defsubr (&Sdbus_call_method);
 789
 790   Qdbus_send_signal = intern ("dbus-send-signal");
 791   staticpro (&Qdbus_send_signal);
 792   defsubr (&Sdbus_send_signal);
 793
 794   Qdbus_register_signal = intern ("dbus-register-signal");
 795   staticpro (&Qdbus_register_signal);
 796   defsubr (&Sdbus_register_signal);
 797
 798   Qdbus_unregister_signal = intern ("dbus-unregister-signal");
 799   staticpro (&Qdbus_unregister_signal);
 800   defsubr (&Sdbus_unregister_signal);
 801
 802   Qdbus_error = intern ("dbus-error");
 803   staticpro (&Qdbus_error);
 804   Fput (Qdbus_error, Qerror_conditions,
 805         list2 (Qdbus_error, Qerror));
 806   Fput (Qdbus_error, Qerror_message,
 807         build_string ("D-Bus error"));
 808
 809   QCdbus_system_bus = intern (":system");
 810   staticpro (&QCdbus_system_bus);
 811
 812   QCdbus_session_bus = intern (":session");
 813   staticpro (&QCdbus_session_bus);
 814
 815   DEFVAR_LISP ("dbus-registered-functions-table", &Vdbus_registered_functions_table,
 816     doc: /* Hash table of registered functions for D-Bus.
 817 The key in the hash table is the list (BUS MEMBER INTERFACE).  BUS is
 818 either the symbol `:system' or the symbol `:session'.  INTERFACE is a
 819 string which denotes a D-Bus interface, and MEMBER, also a string, is
 820 either a method or a signal INTERFACE is offering.  All arguments but
 821 BUS must not be nil.
 822
 823 The value in the hash table is a list of triple lists
 824 \((SERVICE UNAME PATH HANDLER) (SERVICE UNAME PATH HANDLER) ...).
 825 SERVICE is the service name as registered, UNAME is the corresponding
 826 unique name.  PATH is the object path of the sending object.  All of
 827 them be nil, which means a wildcard then.  HANDLER is the function to
 828 be called when a D-Bus message, which matches the key criteria,
 829 arrives.  */);
 830   /* We initialize Vdbus_registered_functions_table in dbus.el,
 831      because we need to define a hash table function first.  */
 832   Vdbus_registered_functions_table = Qnil;
 833
 834   DEFVAR_LISP ("dbus-debug", &Vdbus_debug,
 835     doc: /* If non-nil, debug messages of D-Bus bindings are raised.  */);
 836 #ifdef DBUS_DEBUG
 837   Vdbus_debug = Qt;
 838 #else
 839   Vdbus_debug = Qnil;
 840 #endif
 841
 842   Fprovide (intern ("dbusbind"), Qnil);
 843
 844 }
 845
 846 #endif /* HAVE_DBUS */
 847
 848 /* arch-tag: 0e828477-b571-4fe4-b559-5c9211bc14b8
 849    (do not change this comment) */