cgit.sxemacs.org Git - sxemacs/blob - modules/dbus/dbusbind.c

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