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