HCoop / bpt / emacs.git / blob
? search:


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