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