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