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