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