HCoop / bpt / emacs.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
Add 2010 to copyright years.
[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 {
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 DBusMessageIter subiter;
692 int subtype;
693 result = Qnil;
694 GCPRO1 (result);
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 ("fd %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. DATA is
785 the used bus, either QCdbus_system_bus or QCdbus_session_bus. */
786 void
787 xd_remove_watch (watch, data)
788 DBusWatch *watch;
789 void *data;
790 {
791 /* We check only for incoming data. */
792 if (dbus_watch_get_flags (watch) & DBUS_WATCH_READABLE)
793 {
794 #if HAVE_DBUS_WATCH_GET_UNIX_FD
795 /* TODO: Reverse these on Win32, which prefers the opposite. */
796 int fd = dbus_watch_get_unix_fd(watch);
797 if (fd == -1)
798 fd = dbus_watch_get_socket(watch);
799 #else
800 int fd = dbus_watch_get_fd(watch);
801 #endif
802 XD_DEBUG_MESSAGE ("fd %d", fd);
803
804 if (fd == -1)
805 return;
806
807 /* Unset session environment. */
808 if ((data != NULL) && (data == (void*) XHASH (QCdbus_session_bus)))
809 {
810 XD_DEBUG_MESSAGE ("unsetenv DBUS_SESSION_BUS_ADDRESS");
811 unsetenv ("DBUS_SESSION_BUS_ADDRESS");
812 }
813
814 /* Remove the file descriptor from input_wait_mask. */
815 delete_keyboard_wait_descriptor (fd);
816 }
817
818 /* Return. */
819 return;
820 }
821
822 DEFUN ("dbus-init-bus", Fdbus_init_bus, Sdbus_init_bus, 1, 1, 0,
823 doc: /* Initialize connection to D-Bus BUS.
824 This is an internal function, it shall not be used outside dbus.el. */)
825 (bus)
826 Lisp_Object bus;
827 {
828 DBusConnection *connection;
829
830 /* Check parameters. */
831 CHECK_SYMBOL (bus);
832
833 /* Open a connection to the bus. */
834 connection = xd_initialize (bus);
835
836 /* Add the watch functions. We pass also the bus as data, in order
837 to distinguish between the busses in xd_remove_watch. */
838 if (!dbus_connection_set_watch_functions (connection,
839 xd_add_watch,
840 xd_remove_watch,
841 NULL, (void*) XHASH (bus), NULL))
842 XD_SIGNAL1 (build_string ("Cannot add watch functions"));
843
844 /* Return. */
845 return Qnil;
846 }
847
848 DEFUN ("dbus-get-unique-name", Fdbus_get_unique_name, Sdbus_get_unique_name,
849 1, 1, 0,
850 doc: /* Return the unique name of Emacs registered at D-Bus BUS. */)
851 (bus)
852 Lisp_Object bus;
853 {
854 DBusConnection *connection;
855 const char *name;
856
857 /* Check parameters. */
858 CHECK_SYMBOL (bus);
859
860 /* Open a connection to the bus. */
861 connection = xd_initialize (bus);
862
863 /* Request the name. */
864 name = dbus_bus_get_unique_name (connection);
865 if (name == NULL)
866 XD_SIGNAL1 (build_string ("No unique name available"));
867
868 /* Return. */
869 return build_string (name);
870 }
871
872 DEFUN ("dbus-call-method", Fdbus_call_method, Sdbus_call_method, 5, MANY, 0,
873 doc: /* Call METHOD on the D-Bus BUS.
874
875 BUS is either the symbol `:system' or the symbol `:session'.
876
877 SERVICE is the D-Bus service name to be used. PATH is the D-Bus
878 object path SERVICE is registered at. INTERFACE is an interface
879 offered by SERVICE. It must provide METHOD.
880
881 If the parameter `:timeout' is given, the following integer TIMEOUT
882 specifies the maximum number of milliseconds the method call must
883 return. The default value is 25,000. If the method call doesn't
884 return in time, a D-Bus error is raised.
885
886 All other arguments ARGS are passed to METHOD as arguments. They are
887 converted into D-Bus types via the following rules:
888
889 t and nil => DBUS_TYPE_BOOLEAN
890 number => DBUS_TYPE_UINT32
891 integer => DBUS_TYPE_INT32
892 float => DBUS_TYPE_DOUBLE
893 string => DBUS_TYPE_STRING
894 list => DBUS_TYPE_ARRAY
895
896 All arguments can be preceded by a type symbol. For details about
897 type symbols, see Info node `(dbus)Type Conversion'.
898
899 `dbus-call-method' returns the resulting values of METHOD as a list of
900 Lisp objects. The type conversion happens the other direction as for
901 input arguments. It follows the mapping rules:
902
903 DBUS_TYPE_BOOLEAN => t or nil
904 DBUS_TYPE_BYTE => number
905 DBUS_TYPE_UINT16 => number
906 DBUS_TYPE_INT16 => integer
907 DBUS_TYPE_UINT32 => number or float
908 DBUS_TYPE_INT32 => integer or float
909 DBUS_TYPE_UINT64 => number or float
910 DBUS_TYPE_INT64 => integer or float
911 DBUS_TYPE_DOUBLE => float
912 DBUS_TYPE_STRING => string
913 DBUS_TYPE_OBJECT_PATH => string
914 DBUS_TYPE_SIGNATURE => string
915 DBUS_TYPE_ARRAY => list
916 DBUS_TYPE_VARIANT => list
917 DBUS_TYPE_STRUCT => list
918 DBUS_TYPE_DICT_ENTRY => list
919
920 Example:
921
922 \(dbus-call-method
923 :session "org.gnome.seahorse" "/org/gnome/seahorse/keys/openpgp"
924 "org.gnome.seahorse.Keys" "GetKeyField"
925 "openpgp:657984B8C7A966DD" "simple-name")
926
927 => (t ("Philip R. Zimmermann"))
928
929 If the result of the METHOD call is just one value, the converted Lisp
930 object is returned instead of a list containing this single Lisp object.
931
932 \(dbus-call-method
933 :system "org.freedesktop.Hal" "/org/freedesktop/Hal/devices/computer"
934 "org.freedesktop.Hal.Device" "GetPropertyString"
935 "system.kernel.machine")
936
937 => "i686"
938
939 usage: (dbus-call-method BUS SERVICE PATH INTERFACE METHOD &optional :timeout TIMEOUT &rest ARGS) */)
940 (nargs, args)
941 int nargs;
942 register Lisp_Object *args;
943 {
944 Lisp_Object bus, service, path, interface, method;
945 Lisp_Object result;
946 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
947 DBusConnection *connection;
948 DBusMessage *dmessage;
949 DBusMessage *reply;
950 DBusMessageIter iter;
951 DBusError derror;
952 unsigned int dtype;
953 int timeout = -1;
954 int i = 5;
955 char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
956
957 /* Check parameters. */
958 bus = args[0];
959 service = args[1];
960 path = args[2];
961 interface = args[3];
962 method = args[4];
963
964 CHECK_SYMBOL (bus);
965 CHECK_STRING (service);
966 CHECK_STRING (path);
967 CHECK_STRING (interface);
968 CHECK_STRING (method);
969 GCPRO5 (bus, service, path, interface, method);
970
971 XD_DEBUG_MESSAGE ("%s %s %s %s",
972 SDATA (service),
973 SDATA (path),
974 SDATA (interface),
975 SDATA (method));
976
977 /* Open a connection to the bus. */
978 connection = xd_initialize (bus);
979
980 /* Create the message. */
981 dmessage = dbus_message_new_method_call (SDATA (service),
982 SDATA (path),
983 SDATA (interface),
984 SDATA (method));
985 UNGCPRO;
986 if (dmessage == NULL)
987 XD_SIGNAL1 (build_string ("Unable to create a new message"));
988
989 /* Check for timeout parameter. */
990 if ((i+2 <= nargs) && (EQ ((args[i]), QCdbus_timeout)))
991 {
992 CHECK_NATNUM (args[i+1]);
993 timeout = XUINT (args[i+1]);
994 i = i+2;
995 }
996
997 /* Initialize parameter list of message. */
998 dbus_message_iter_init_append (dmessage, &iter);
999
1000 /* Append parameters to the message. */
1001 for (; i < nargs; ++i)
1002 {
1003 dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1004 if (XD_DBUS_TYPE_P (args[i]))
1005 {
1006 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1007 XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1008 XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-4,
1009 SDATA (format2 ("%s", args[i], Qnil)),
1010 SDATA (format2 ("%s", args[i+1], Qnil)));
1011 ++i;
1012 }
1013 else
1014 {
1015 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1016 XD_DEBUG_MESSAGE ("Parameter%d %s", i-4,
1017 SDATA (format2 ("%s", args[i], Qnil)));
1018 }
1019
1020 /* Check for valid signature. We use DBUS_TYPE_INVALID as
1021 indication that there is no parent type. */
1022 xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1023
1024 xd_append_arg (dtype, args[i], &iter);
1025 }
1026
1027 /* Send the message. */
1028 dbus_error_init (&derror);
1029 reply = dbus_connection_send_with_reply_and_block (connection,
1030 dmessage,
1031 timeout,
1032 &derror);
1033
1034 if (dbus_error_is_set (&derror))
1035 XD_ERROR (derror);
1036
1037 if (reply == NULL)
1038 XD_SIGNAL1 (build_string ("No reply"));
1039
1040 XD_DEBUG_MESSAGE ("Message sent");
1041
1042 /* Collect the results. */
1043 result = Qnil;
1044 GCPRO1 (result);
1045
1046 if (dbus_message_iter_init (reply, &iter))
1047 {
1048 /* Loop over the parameters of the D-Bus reply message. Construct a
1049 Lisp list, which is returned by `dbus-call-method'. */
1050 while ((dtype = dbus_message_iter_get_arg_type (&iter))
1051 != DBUS_TYPE_INVALID)
1052 {
1053 result = Fcons (xd_retrieve_arg (dtype, &iter), result);
1054 dbus_message_iter_next (&iter);
1055 }
1056 }
1057 else
1058 {
1059 /* No arguments: just return nil. */
1060 }
1061
1062 /* Cleanup. */
1063 dbus_error_free (&derror);
1064 dbus_message_unref (dmessage);
1065 dbus_message_unref (reply);
1066
1067 /* Return the result. If there is only one single Lisp object,
1068 return it as-it-is, otherwise return the reversed list. */
1069 if (XUINT (Flength (result)) == 1)
1070 RETURN_UNGCPRO (CAR_SAFE (result));
1071 else
1072 RETURN_UNGCPRO (Fnreverse (result));
1073 }
1074
1075 DEFUN ("dbus-call-method-asynchronously", Fdbus_call_method_asynchronously,
1076 Sdbus_call_method_asynchronously, 6, MANY, 0,
1077 doc: /* Call METHOD on the D-Bus BUS asynchronously.
1078
1079 BUS is either the symbol `:system' or the symbol `:session'.
1080
1081 SERVICE is the D-Bus service name to be used. PATH is the D-Bus
1082 object path SERVICE is registered at. INTERFACE is an interface
1083 offered by SERVICE. It must provide METHOD.
1084
1085 HANDLER is a Lisp function, which is called when the corresponding
1086 return message has arrived. If HANDLER is nil, no return message will
1087 be expected.
1088
1089 If the parameter `:timeout' is given, the following integer TIMEOUT
1090 specifies the maximum number of milliseconds the method call must
1091 return. The default value is 25,000. If the method call doesn't
1092 return in time, a D-Bus error is raised.
1093
1094 All other arguments ARGS are passed to METHOD as arguments. They are
1095 converted into D-Bus types via the following rules:
1096
1097 t and nil => DBUS_TYPE_BOOLEAN
1098 number => DBUS_TYPE_UINT32
1099 integer => DBUS_TYPE_INT32
1100 float => DBUS_TYPE_DOUBLE
1101 string => DBUS_TYPE_STRING
1102 list => DBUS_TYPE_ARRAY
1103
1104 All arguments can be preceded by a type symbol. For details about
1105 type symbols, see Info node `(dbus)Type Conversion'.
1106
1107 Unless HANDLER is nil, the function returns a key into the hash table
1108 `dbus-registered-objects-table'. The corresponding entry in the hash
1109 table is removed, when the return message has been arrived, and
1110 HANDLER is called.
1111
1112 Example:
1113
1114 \(dbus-call-method-asynchronously
1115 :system "org.freedesktop.Hal" "/org/freedesktop/Hal/devices/computer"
1116 "org.freedesktop.Hal.Device" "GetPropertyString" 'message
1117 "system.kernel.machine")
1118
1119 => (:system 2)
1120
1121 -| i686
1122
1123 usage: (dbus-call-method-asynchronously BUS SERVICE PATH INTERFACE METHOD HANDLER &optional :timeout TIMEOUT &rest ARGS) */)
1124 (nargs, args)
1125 int nargs;
1126 register Lisp_Object *args;
1127 {
1128 Lisp_Object bus, service, path, interface, method, handler;
1129 Lisp_Object result;
1130 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5, gcpro6;
1131 DBusConnection *connection;
1132 DBusMessage *dmessage;
1133 DBusMessageIter iter;
1134 unsigned int dtype;
1135 int timeout = -1;
1136 int i = 6;
1137 char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1138
1139 /* Check parameters. */
1140 bus = args[0];
1141 service = args[1];
1142 path = args[2];
1143 interface = args[3];
1144 method = args[4];
1145 handler = args[5];
1146
1147 CHECK_SYMBOL (bus);
1148 CHECK_STRING (service);
1149 CHECK_STRING (path);
1150 CHECK_STRING (interface);
1151 CHECK_STRING (method);
1152 if (!NILP (handler) && !FUNCTIONP (handler))
1153 wrong_type_argument (intern ("functionp"), handler);
1154 GCPRO6 (bus, service, path, interface, method, handler);
1155
1156 XD_DEBUG_MESSAGE ("%s %s %s %s",
1157 SDATA (service),
1158 SDATA (path),
1159 SDATA (interface),
1160 SDATA (method));
1161
1162 /* Open a connection to the bus. */
1163 connection = xd_initialize (bus);
1164
1165 /* Create the message. */
1166 dmessage = dbus_message_new_method_call (SDATA (service),
1167 SDATA (path),
1168 SDATA (interface),
1169 SDATA (method));
1170 if (dmessage == NULL)
1171 XD_SIGNAL1 (build_string ("Unable to create a new message"));
1172
1173 /* Check for timeout parameter. */
1174 if ((i+2 <= nargs) && (EQ ((args[i]), QCdbus_timeout)))
1175 {
1176 CHECK_NATNUM (args[i+1]);
1177 timeout = XUINT (args[i+1]);
1178 i = i+2;
1179 }
1180
1181 /* Initialize parameter list of message. */
1182 dbus_message_iter_init_append (dmessage, &iter);
1183
1184 /* Append parameters to the message. */
1185 for (; i < nargs; ++i)
1186 {
1187 dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1188 if (XD_DBUS_TYPE_P (args[i]))
1189 {
1190 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1191 XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1192 XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-4,
1193 SDATA (format2 ("%s", args[i], Qnil)),
1194 SDATA (format2 ("%s", args[i+1], Qnil)));
1195 ++i;
1196 }
1197 else
1198 {
1199 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1200 XD_DEBUG_MESSAGE ("Parameter%d %s", i-4,
1201 SDATA (format2 ("%s", args[i], Qnil)));
1202 }
1203
1204 /* Check for valid signature. We use DBUS_TYPE_INVALID as
1205 indication that there is no parent type. */
1206 xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1207
1208 xd_append_arg (dtype, args[i], &iter);
1209 }
1210
1211 if (!NILP (handler))
1212 {
1213 /* Send the message. The message is just added to the outgoing
1214 message queue. */
1215 if (!dbus_connection_send_with_reply (connection, dmessage,
1216 NULL, timeout))
1217 XD_SIGNAL1 (build_string ("Cannot send message"));
1218
1219 /* The result is the key in Vdbus_registered_objects_table. */
1220 result = (list2 (bus, make_number (dbus_message_get_serial (dmessage))));
1221
1222 /* Create a hash table entry. */
1223 Fputhash (result, handler, Vdbus_registered_objects_table);
1224 }
1225 else
1226 {
1227 /* Send the message. The message is just added to the outgoing
1228 message queue. */
1229 if (!dbus_connection_send (connection, dmessage, NULL))
1230 XD_SIGNAL1 (build_string ("Cannot send message"));
1231
1232 result = Qnil;
1233 }
1234
1235 /* Flush connection to ensure the message is handled. */
1236 dbus_connection_flush (connection);
1237
1238 XD_DEBUG_MESSAGE ("Message sent");
1239
1240 /* Cleanup. */
1241 dbus_message_unref (dmessage);
1242
1243 /* Return the result. */
1244 RETURN_UNGCPRO (result);
1245 }
1246
1247 DEFUN ("dbus-method-return-internal", Fdbus_method_return_internal,
1248 Sdbus_method_return_internal,
1249 3, MANY, 0,
1250 doc: /* Return for message SERIAL on the D-Bus BUS.
1251 This is an internal function, it shall not be used outside dbus.el.
1252
1253 usage: (dbus-method-return-internal BUS SERIAL SERVICE &rest ARGS) */)
1254 (nargs, args)
1255 int nargs;
1256 register Lisp_Object *args;
1257 {
1258 Lisp_Object bus, serial, service;
1259 struct gcpro gcpro1, gcpro2, gcpro3;
1260 DBusConnection *connection;
1261 DBusMessage *dmessage;
1262 DBusMessageIter iter;
1263 unsigned int dtype;
1264 int i;
1265 char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1266
1267 /* Check parameters. */
1268 bus = args[0];
1269 serial = args[1];
1270 service = args[2];
1271
1272 CHECK_SYMBOL (bus);
1273 CHECK_NUMBER (serial);
1274 CHECK_STRING (service);
1275 GCPRO3 (bus, serial, service);
1276
1277 XD_DEBUG_MESSAGE ("%lu %s ", (unsigned long) XUINT (serial), SDATA (service));
1278
1279 /* Open a connection to the bus. */
1280 connection = xd_initialize (bus);
1281
1282 /* Create the message. */
1283 dmessage = dbus_message_new (DBUS_MESSAGE_TYPE_METHOD_RETURN);
1284 if ((dmessage == NULL)
1285 || (!dbus_message_set_reply_serial (dmessage, XUINT (serial)))
1286 || (!dbus_message_set_destination (dmessage, SDATA (service))))
1287 {
1288 UNGCPRO;
1289 XD_SIGNAL1 (build_string ("Unable to create a return message"));
1290 }
1291
1292 UNGCPRO;
1293
1294 /* Initialize parameter list of message. */
1295 dbus_message_iter_init_append (dmessage, &iter);
1296
1297 /* Append parameters to the message. */
1298 for (i = 3; i < nargs; ++i)
1299 {
1300 dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1301 if (XD_DBUS_TYPE_P (args[i]))
1302 {
1303 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1304 XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1305 XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-2,
1306 SDATA (format2 ("%s", args[i], Qnil)),
1307 SDATA (format2 ("%s", args[i+1], Qnil)));
1308 ++i;
1309 }
1310 else
1311 {
1312 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1313 XD_DEBUG_MESSAGE ("Parameter%d %s", i-2,
1314 SDATA (format2 ("%s", args[i], Qnil)));
1315 }
1316
1317 /* Check for valid signature. We use DBUS_TYPE_INVALID as
1318 indication that there is no parent type. */
1319 xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1320
1321 xd_append_arg (dtype, args[i], &iter);
1322 }
1323
1324 /* Send the message. The message is just added to the outgoing
1325 message queue. */
1326 if (!dbus_connection_send (connection, dmessage, NULL))
1327 XD_SIGNAL1 (build_string ("Cannot send message"));
1328
1329 /* Flush connection to ensure the message is handled. */
1330 dbus_connection_flush (connection);
1331
1332 XD_DEBUG_MESSAGE ("Message sent");
1333
1334 /* Cleanup. */
1335 dbus_message_unref (dmessage);
1336
1337 /* Return. */
1338 return Qt;
1339 }
1340
1341 DEFUN ("dbus-method-error-internal", Fdbus_method_error_internal,
1342 Sdbus_method_error_internal,
1343 3, MANY, 0,
1344 doc: /* Return error message for message SERIAL on the D-Bus BUS.
1345 This is an internal function, it shall not be used outside dbus.el.
1346
1347 usage: (dbus-method-error-internal BUS SERIAL SERVICE &rest ARGS) */)
1348 (nargs, args)
1349 int nargs;
1350 register Lisp_Object *args;
1351 {
1352 Lisp_Object bus, serial, service;
1353 struct gcpro gcpro1, gcpro2, gcpro3;
1354 DBusConnection *connection;
1355 DBusMessage *dmessage;
1356 DBusMessageIter iter;
1357 unsigned int dtype;
1358 int i;
1359 char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1360
1361 /* Check parameters. */
1362 bus = args[0];
1363 serial = args[1];
1364 service = args[2];
1365
1366 CHECK_SYMBOL (bus);
1367 CHECK_NUMBER (serial);
1368 CHECK_STRING (service);
1369 GCPRO3 (bus, serial, service);
1370
1371 XD_DEBUG_MESSAGE ("%lu %s ", (unsigned long) XUINT (serial), SDATA (service));
1372
1373 /* Open a connection to the bus. */
1374 connection = xd_initialize (bus);
1375
1376 /* Create the message. */
1377 dmessage = dbus_message_new (DBUS_MESSAGE_TYPE_ERROR);
1378 if ((dmessage == NULL)
1379 || (!dbus_message_set_error_name (dmessage, DBUS_ERROR_FAILED))
1380 || (!dbus_message_set_reply_serial (dmessage, XUINT (serial)))
1381 || (!dbus_message_set_destination (dmessage, SDATA (service))))
1382 {
1383 UNGCPRO;
1384 XD_SIGNAL1 (build_string ("Unable to create a error message"));
1385 }
1386
1387 UNGCPRO;
1388
1389 /* Initialize parameter list of message. */
1390 dbus_message_iter_init_append (dmessage, &iter);
1391
1392 /* Append parameters to the message. */
1393 for (i = 3; i < nargs; ++i)
1394 {
1395 dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1396 if (XD_DBUS_TYPE_P (args[i]))
1397 {
1398 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1399 XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1400 XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-2,
1401 SDATA (format2 ("%s", args[i], Qnil)),
1402 SDATA (format2 ("%s", args[i+1], Qnil)));
1403 ++i;
1404 }
1405 else
1406 {
1407 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1408 XD_DEBUG_MESSAGE ("Parameter%d %s", i-2,
1409 SDATA (format2 ("%s", args[i], Qnil)));
1410 }
1411
1412 /* Check for valid signature. We use DBUS_TYPE_INVALID as
1413 indication that there is no parent type. */
1414 xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1415
1416 xd_append_arg (dtype, args[i], &iter);
1417 }
1418
1419 /* Send the message. The message is just added to the outgoing
1420 message queue. */
1421 if (!dbus_connection_send (connection, dmessage, NULL))
1422 XD_SIGNAL1 (build_string ("Cannot send message"));
1423
1424 /* Flush connection to ensure the message is handled. */
1425 dbus_connection_flush (connection);
1426
1427 XD_DEBUG_MESSAGE ("Message sent");
1428
1429 /* Cleanup. */
1430 dbus_message_unref (dmessage);
1431
1432 /* Return. */
1433 return Qt;
1434 }
1435
1436 DEFUN ("dbus-send-signal", Fdbus_send_signal, Sdbus_send_signal, 5, MANY, 0,
1437 doc: /* Send signal SIGNAL on the D-Bus BUS.
1438
1439 BUS is either the symbol `:system' or the symbol `:session'.
1440
1441 SERVICE is the D-Bus service name SIGNAL is sent from. PATH is the
1442 D-Bus object path SERVICE is registered at. INTERFACE is an interface
1443 offered by SERVICE. It must provide signal SIGNAL.
1444
1445 All other arguments ARGS are passed to SIGNAL as arguments. They are
1446 converted into D-Bus types via the following rules:
1447
1448 t and nil => DBUS_TYPE_BOOLEAN
1449 number => DBUS_TYPE_UINT32
1450 integer => DBUS_TYPE_INT32
1451 float => DBUS_TYPE_DOUBLE
1452 string => DBUS_TYPE_STRING
1453 list => DBUS_TYPE_ARRAY
1454
1455 All arguments can be preceded by a type symbol. For details about
1456 type symbols, see Info node `(dbus)Type Conversion'.
1457
1458 Example:
1459
1460 \(dbus-send-signal
1461 :session "org.gnu.Emacs" "/org/gnu/Emacs"
1462 "org.gnu.Emacs.FileManager" "FileModified" "/home/albinus/.emacs")
1463
1464 usage: (dbus-send-signal BUS SERVICE PATH INTERFACE SIGNAL &rest ARGS) */)
1465 (nargs, args)
1466 int nargs;
1467 register Lisp_Object *args;
1468 {
1469 Lisp_Object bus, service, path, interface, signal;
1470 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5;
1471 DBusConnection *connection;
1472 DBusMessage *dmessage;
1473 DBusMessageIter iter;
1474 unsigned int dtype;
1475 int i;
1476 char signature[DBUS_MAXIMUM_SIGNATURE_LENGTH];
1477
1478 /* Check parameters. */
1479 bus = args[0];
1480 service = args[1];
1481 path = args[2];
1482 interface = args[3];
1483 signal = args[4];
1484
1485 CHECK_SYMBOL (bus);
1486 CHECK_STRING (service);
1487 CHECK_STRING (path);
1488 CHECK_STRING (interface);
1489 CHECK_STRING (signal);
1490 GCPRO5 (bus, service, path, interface, signal);
1491
1492 XD_DEBUG_MESSAGE ("%s %s %s %s",
1493 SDATA (service),
1494 SDATA (path),
1495 SDATA (interface),
1496 SDATA (signal));
1497
1498 /* Open a connection to the bus. */
1499 connection = xd_initialize (bus);
1500
1501 /* Create the message. */
1502 dmessage = dbus_message_new_signal (SDATA (path),
1503 SDATA (interface),
1504 SDATA (signal));
1505 UNGCPRO;
1506 if (dmessage == NULL)
1507 XD_SIGNAL1 (build_string ("Unable to create a new message"));
1508
1509 /* Initialize parameter list of message. */
1510 dbus_message_iter_init_append (dmessage, &iter);
1511
1512 /* Append parameters to the message. */
1513 for (i = 5; i < nargs; ++i)
1514 {
1515 dtype = XD_OBJECT_TO_DBUS_TYPE (args[i]);
1516 if (XD_DBUS_TYPE_P (args[i]))
1517 {
1518 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1519 XD_DEBUG_VALID_LISP_OBJECT_P (args[i+1]);
1520 XD_DEBUG_MESSAGE ("Parameter%d %s %s", i-4,
1521 SDATA (format2 ("%s", args[i], Qnil)),
1522 SDATA (format2 ("%s", args[i+1], Qnil)));
1523 ++i;
1524 }
1525 else
1526 {
1527 XD_DEBUG_VALID_LISP_OBJECT_P (args[i]);
1528 XD_DEBUG_MESSAGE ("Parameter%d %s", i-4,
1529 SDATA (format2 ("%s", args[i], Qnil)));
1530 }
1531
1532 /* Check for valid signature. We use DBUS_TYPE_INVALID as
1533 indication that there is no parent type. */
1534 xd_signature (signature, dtype, DBUS_TYPE_INVALID, args[i]);
1535
1536 xd_append_arg (dtype, args[i], &iter);
1537 }
1538
1539 /* Send the message. The message is just added to the outgoing
1540 message queue. */
1541 if (!dbus_connection_send (connection, dmessage, NULL))
1542 XD_SIGNAL1 (build_string ("Cannot send message"));
1543
1544 /* Flush connection to ensure the message is handled. */
1545 dbus_connection_flush (connection);
1546
1547 XD_DEBUG_MESSAGE ("Signal sent");
1548
1549 /* Cleanup. */
1550 dbus_message_unref (dmessage);
1551
1552 /* Return. */
1553 return Qt;
1554 }
1555
1556 /* Check, whether there is pending input in the message queue of the
1557 D-Bus BUS. BUS is a Lisp symbol, either :system or :session. */
1558 int
1559 xd_get_dispatch_status (bus)
1560 Lisp_Object bus;
1561 {
1562 DBusConnection *connection;
1563
1564 /* Open a connection to the bus. */
1565 connection = xd_initialize (bus);
1566
1567 /* Non blocking read of the next available message. */
1568 dbus_connection_read_write (connection, 0);
1569
1570 /* Return. */
1571 return
1572 (dbus_connection_get_dispatch_status (connection)
1573 == DBUS_DISPATCH_DATA_REMAINS)
1574 ? TRUE : FALSE;
1575 }
1576
1577 /* Check for queued incoming messages from the system and session buses. */
1578 int
1579 xd_pending_messages ()
1580 {
1581
1582 /* Vdbus_registered_objects_table will be initialized as hash table
1583 in dbus.el. When this package isn't loaded yet, it doesn't make
1584 sense to handle D-Bus messages. */
1585 return (HASH_TABLE_P (Vdbus_registered_objects_table)
1586 ? (xd_get_dispatch_status (QCdbus_system_bus)
1587 || ((getenv ("DBUS_SESSION_BUS_ADDRESS") != NULL)
1588 ? xd_get_dispatch_status (QCdbus_session_bus)
1589 : FALSE))
1590 : FALSE);
1591 }
1592
1593 /* Read queued incoming message of the D-Bus BUS. BUS is a Lisp
1594 symbol, either :system or :session. */
1595 static Lisp_Object
1596 xd_read_message (bus)
1597 Lisp_Object bus;
1598 {
1599 Lisp_Object args, key, value;
1600 struct gcpro gcpro1;
1601 struct input_event event;
1602 DBusConnection *connection;
1603 DBusMessage *dmessage;
1604 DBusMessageIter iter;
1605 unsigned int dtype;
1606 int mtype, serial;
1607 const char *uname, *path, *interface, *member;
1608
1609 /* Open a connection to the bus. */
1610 connection = xd_initialize (bus);
1611
1612 /* Non blocking read of the next available message. */
1613 dbus_connection_read_write (connection, 0);
1614 dmessage = dbus_connection_pop_message (connection);
1615
1616 /* Return if there is no queued message. */
1617 if (dmessage == NULL)
1618 return Qnil;
1619
1620 /* Collect the parameters. */
1621 args = Qnil;
1622 GCPRO1 (args);
1623
1624 /* Loop over the resulting parameters. Construct a list. */
1625 if (dbus_message_iter_init (dmessage, &iter))
1626 {
1627 while ((dtype = dbus_message_iter_get_arg_type (&iter))
1628 != DBUS_TYPE_INVALID)
1629 {
1630 args = Fcons (xd_retrieve_arg (dtype, &iter), args);
1631 dbus_message_iter_next (&iter);
1632 }
1633 /* The arguments are stored in reverse order. Reorder them. */
1634 args = Fnreverse (args);
1635 }
1636
1637 /* Read message type, message serial, unique name, object path,
1638 interface and member from the message. */
1639 mtype = dbus_message_get_type (dmessage);
1640 serial =
1641 ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1642 || (mtype == DBUS_MESSAGE_TYPE_ERROR))
1643 ? dbus_message_get_reply_serial (dmessage)
1644 : dbus_message_get_serial (dmessage);
1645 uname = dbus_message_get_sender (dmessage);
1646 path = dbus_message_get_path (dmessage);
1647 interface = dbus_message_get_interface (dmessage);
1648 member = dbus_message_get_member (dmessage);
1649
1650 XD_DEBUG_MESSAGE ("Event received: %s %d %s %s %s %s %s",
1651 (mtype == DBUS_MESSAGE_TYPE_INVALID)
1652 ? "DBUS_MESSAGE_TYPE_INVALID"
1653 : (mtype == DBUS_MESSAGE_TYPE_METHOD_CALL)
1654 ? "DBUS_MESSAGE_TYPE_METHOD_CALL"
1655 : (mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1656 ? "DBUS_MESSAGE_TYPE_METHOD_RETURN"
1657 : (mtype == DBUS_MESSAGE_TYPE_ERROR)
1658 ? "DBUS_MESSAGE_TYPE_ERROR"
1659 : "DBUS_MESSAGE_TYPE_SIGNAL",
1660 serial, uname, path, interface, member,
1661 SDATA (format2 ("%s", args, Qnil)));
1662
1663 if ((mtype == DBUS_MESSAGE_TYPE_METHOD_RETURN)
1664 || (mtype == DBUS_MESSAGE_TYPE_ERROR))
1665 {
1666 /* Search for a registered function of the message. */
1667 key = list2 (bus, make_number (serial));
1668 value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1669
1670 /* There shall be exactly one entry. Construct an event. */
1671 if (NILP (value))
1672 goto cleanup;
1673
1674 /* Remove the entry. */
1675 Fremhash (key, Vdbus_registered_objects_table);
1676
1677 /* Construct an event. */
1678 EVENT_INIT (event);
1679 event.kind = DBUS_EVENT;
1680 event.frame_or_window = Qnil;
1681 event.arg = Fcons (value, args);
1682 }
1683
1684 else /* (mtype != DBUS_MESSAGE_TYPE_METHOD_RETURN) */
1685 {
1686 /* Vdbus_registered_objects_table requires non-nil interface and
1687 member. */
1688 if ((interface == NULL) || (member == NULL))
1689 goto cleanup;
1690
1691 /* Search for a registered function of the message. */
1692 key = list3 (bus, build_string (interface), build_string (member));
1693 value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1694
1695 /* Loop over the registered functions. Construct an event. */
1696 while (!NILP (value))
1697 {
1698 key = CAR_SAFE (value);
1699 /* key has the structure (UNAME SERVICE PATH HANDLER). */
1700 if (((uname == NULL)
1701 || (NILP (CAR_SAFE (key)))
1702 || (strcmp (uname, SDATA (CAR_SAFE (key))) == 0))
1703 && ((path == NULL)
1704 || (NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1705 || (strcmp (path,
1706 SDATA (CAR_SAFE (CDR_SAFE (CDR_SAFE (key)))))
1707 == 0))
1708 && (!NILP (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))))))
1709 {
1710 EVENT_INIT (event);
1711 event.kind = DBUS_EVENT;
1712 event.frame_or_window = Qnil;
1713 event.arg = Fcons (CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (key)))),
1714 args);
1715 break;
1716 }
1717 value = CDR_SAFE (value);
1718 }
1719
1720 if (NILP (value))
1721 goto cleanup;
1722 }
1723
1724 /* Add type, serial, uname, path, interface and member to the event. */
1725 event.arg = Fcons ((member == NULL ? Qnil : build_string (member)),
1726 event.arg);
1727 event.arg = Fcons ((interface == NULL ? Qnil : build_string (interface)),
1728 event.arg);
1729 event.arg = Fcons ((path == NULL ? Qnil : build_string (path)),
1730 event.arg);
1731 event.arg = Fcons ((uname == NULL ? Qnil : build_string (uname)),
1732 event.arg);
1733 event.arg = Fcons (make_number (serial), event.arg);
1734 event.arg = Fcons (make_number (mtype), event.arg);
1735
1736 /* Add the bus symbol to the event. */
1737 event.arg = Fcons (bus, event.arg);
1738
1739 /* Store it into the input event queue. */
1740 kbd_buffer_store_event (&event);
1741
1742 XD_DEBUG_MESSAGE ("Event stored: %s",
1743 SDATA (format2 ("%s", event.arg, Qnil)));
1744
1745 /* Cleanup. */
1746 cleanup:
1747 dbus_message_unref (dmessage);
1748
1749 RETURN_UNGCPRO (Qnil);
1750 }
1751
1752 /* Read queued incoming messages from the system and session buses. */
1753 void
1754 xd_read_queued_messages ()
1755 {
1756
1757 /* Vdbus_registered_objects_table will be initialized as hash table
1758 in dbus.el. When this package isn't loaded yet, it doesn't make
1759 sense to handle D-Bus messages. Furthermore, we ignore all Lisp
1760 errors during the call. */
1761 if (HASH_TABLE_P (Vdbus_registered_objects_table))
1762 {
1763 xd_in_read_queued_messages = 1;
1764 internal_catch (Qdbus_error, xd_read_message, QCdbus_system_bus);
1765 internal_catch (Qdbus_error, xd_read_message, QCdbus_session_bus);
1766 xd_in_read_queued_messages = 0;
1767 }
1768 }
1769
1770 DEFUN ("dbus-register-signal", Fdbus_register_signal, Sdbus_register_signal,
1771 6, MANY, 0,
1772 doc: /* Register for signal SIGNAL on the D-Bus BUS.
1773
1774 BUS is either the symbol `:system' or the symbol `:session'.
1775
1776 SERVICE is the D-Bus service name used by the sending D-Bus object.
1777 It can be either a known name or the unique name of the D-Bus object
1778 sending the signal. When SERVICE is nil, related signals from all
1779 D-Bus objects shall be accepted.
1780
1781 PATH is the D-Bus object path SERVICE is registered. It can also be
1782 nil if the path name of incoming signals shall not be checked.
1783
1784 INTERFACE is an interface offered by SERVICE. It must provide SIGNAL.
1785 HANDLER is a Lisp function to be called when the signal is received.
1786 It must accept as arguments the values SIGNAL is sending.
1787
1788 All other arguments ARGS, if specified, must be strings. They stand
1789 for the respective arguments of the signal in their order, and are
1790 used for filtering as well. A nil argument might be used to preserve
1791 the order.
1792
1793 INTERFACE, SIGNAL and HANDLER must not be nil. Example:
1794
1795 \(defun my-signal-handler (device)
1796 (message "Device %s added" device))
1797
1798 \(dbus-register-signal
1799 :system "org.freedesktop.Hal" "/org/freedesktop/Hal/Manager"
1800 "org.freedesktop.Hal.Manager" "DeviceAdded" 'my-signal-handler)
1801
1802 => ((:system "org.freedesktop.Hal.Manager" "DeviceAdded")
1803 ("org.freedesktop.Hal" "/org/freedesktop/Hal/Manager" my-signal-handler))
1804
1805 `dbus-register-signal' returns an object, which can be used in
1806 `dbus-unregister-object' for removing the registration.
1807
1808 usage: (dbus-register-signal BUS SERVICE PATH INTERFACE SIGNAL HANDLER &rest ARGS) */)
1809 (nargs, args)
1810 int nargs;
1811 register Lisp_Object *args;
1812 {
1813 Lisp_Object bus, service, path, interface, signal, handler;
1814 struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5, gcpro6;
1815 Lisp_Object uname, key, key1, value;
1816 DBusConnection *connection;
1817 int i;
1818 char rule[DBUS_MAXIMUM_MATCH_RULE_LENGTH];
1819 char x[DBUS_MAXIMUM_MATCH_RULE_LENGTH];
1820 DBusError derror;
1821
1822 /* Check parameters. */
1823 bus = args[0];
1824 service = args[1];
1825 path = args[2];
1826 interface = args[3];
1827 signal = args[4];
1828 handler = args[5];
1829
1830 CHECK_SYMBOL (bus);
1831 if (!NILP (service)) CHECK_STRING (service);
1832 if (!NILP (path)) CHECK_STRING (path);
1833 CHECK_STRING (interface);
1834 CHECK_STRING (signal);
1835 if (!FUNCTIONP (handler))
1836 wrong_type_argument (intern ("functionp"), handler);
1837 GCPRO6 (bus, service, path, interface, signal, handler);
1838
1839 /* Retrieve unique name of service. If service is a known name, we
1840 will register for the corresponding unique name, if any. Signals
1841 are sent always with the unique name as sender. Note: the unique
1842 name of "org.freedesktop.DBus" is that string itself. */
1843 if ((STRINGP (service))
1844 && (SBYTES (service) > 0)
1845 && (strcmp (SDATA (service), DBUS_SERVICE_DBUS) != 0)
1846 && (strncmp (SDATA (service), ":", 1) != 0))
1847 {
1848 uname = call2 (intern ("dbus-get-name-owner"), bus, service);
1849 /* When there is no unique name, we mark it with an empty
1850 string. */
1851 if (NILP (uname))
1852 uname = empty_unibyte_string;
1853 }
1854 else
1855 uname = service;
1856
1857 /* Create a matching rule if the unique name exists (when no
1858 wildcard). */
1859 if (NILP (uname) || (SBYTES (uname) > 0))
1860 {
1861 /* Open a connection to the bus. */
1862 connection = xd_initialize (bus);
1863
1864 /* Create a rule to receive related signals. */
1865 sprintf (rule,
1866 "type='signal',interface='%s',member='%s'",
1867 SDATA (interface),
1868 SDATA (signal));
1869
1870 /* Add unique name and path to the rule if they are non-nil. */
1871 if (!NILP (uname))
1872 {
1873 sprintf (x, ",sender='%s'", SDATA (uname));
1874 strcat (rule, x);
1875 }
1876
1877 if (!NILP (path))
1878 {
1879 sprintf (x, ",path='%s'", SDATA (path));
1880 strcat (rule, x);
1881 }
1882
1883 /* Add arguments to the rule if they are non-nil. */
1884 for (i = 6; i < nargs; ++i)
1885 if (!NILP (args[i]))
1886 {
1887 CHECK_STRING (args[i]);
1888 sprintf (x, ",arg%d='%s'", i-6, SDATA (args[i]));
1889 strcat (rule, x);
1890 }
1891
1892 /* Add the rule to the bus. */
1893 dbus_error_init (&derror);
1894 dbus_bus_add_match (connection, rule, &derror);
1895 if (dbus_error_is_set (&derror))
1896 {
1897 UNGCPRO;
1898 XD_ERROR (derror);
1899 }
1900
1901 /* Cleanup. */
1902 dbus_error_free (&derror);
1903
1904 XD_DEBUG_MESSAGE ("Matching rule \"%s\" created", rule);
1905 }
1906
1907 /* Create a hash table entry. */
1908 key = list3 (bus, interface, signal);
1909 key1 = list4 (uname, service, path, handler);
1910 value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1911
1912 if (NILP (Fmember (key1, value)))
1913 Fputhash (key, Fcons (key1, value), Vdbus_registered_objects_table);
1914
1915 /* Return object. */
1916 RETURN_UNGCPRO (list2 (key, list3 (service, path, handler)));
1917 }
1918
1919 DEFUN ("dbus-register-method", Fdbus_register_method, Sdbus_register_method,
1920 6, 6, 0,
1921 doc: /* Register for method METHOD on the D-Bus BUS.
1922
1923 BUS is either the symbol `:system' or the symbol `:session'.
1924
1925 SERVICE is the D-Bus service name of the D-Bus object METHOD is
1926 registered for. It must be a known name.
1927
1928 PATH is the D-Bus object path SERVICE is registered. INTERFACE is the
1929 interface offered by SERVICE. It must provide METHOD. HANDLER is a
1930 Lisp function to be called when a method call is received. It must
1931 accept the input arguments of METHOD. The return value of HANDLER is
1932 used for composing the returning D-Bus message. */)
1933 (bus, service, path, interface, method, handler)
1934 Lisp_Object bus, service, path, interface, method, handler;
1935 {
1936 Lisp_Object key, key1, value;
1937 DBusConnection *connection;
1938 int result;
1939 DBusError derror;
1940
1941 /* Check parameters. */
1942 CHECK_SYMBOL (bus);
1943 CHECK_STRING (service);
1944 CHECK_STRING (path);
1945 CHECK_STRING (interface);
1946 CHECK_STRING (method);
1947 if (!FUNCTIONP (handler))
1948 wrong_type_argument (intern ("functionp"), handler);
1949 /* TODO: We must check for a valid service name, otherwise there is
1950 a segmentation fault. */
1951
1952 /* Open a connection to the bus. */
1953 connection = xd_initialize (bus);
1954
1955 /* Request the known name from the bus. We can ignore the result,
1956 it is set to -1 if there is an error - kind of redundancy. */
1957 dbus_error_init (&derror);
1958 result = dbus_bus_request_name (connection, SDATA (service), 0, &derror);
1959 if (dbus_error_is_set (&derror))
1960 XD_ERROR (derror);
1961
1962 /* Create a hash table entry. We use nil for the unique name,
1963 because the method might be called from anybody. */
1964 key = list3 (bus, interface, method);
1965 key1 = list4 (Qnil, service, path, handler);
1966 value = Fgethash (key, Vdbus_registered_objects_table, Qnil);
1967
1968 if (NILP (Fmember (key1, value)))
1969 Fputhash (key, Fcons (key1, value), Vdbus_registered_objects_table);
1970
1971 /* Cleanup. */
1972 dbus_error_free (&derror);
1973
1974 /* Return object. */
1975 return list2 (key, list3 (service, path, handler));
1976 }
1977
1978 \f
1979 void
1980 syms_of_dbusbind ()
1981 {
1982
1983 Qdbus_init_bus = intern_c_string ("dbus-init-bus");
1984 staticpro (&Qdbus_init_bus);
1985 defsubr (&Sdbus_init_bus);
1986
1987 Qdbus_get_unique_name = intern_c_string ("dbus-get-unique-name");
1988 staticpro (&Qdbus_get_unique_name);
1989 defsubr (&Sdbus_get_unique_name);
1990
1991 Qdbus_call_method = intern_c_string ("dbus-call-method");
1992 staticpro (&Qdbus_call_method);
1993 defsubr (&Sdbus_call_method);
1994
1995 Qdbus_call_method_asynchronously = intern_c_string ("dbus-call-method-asynchronously");
1996 staticpro (&Qdbus_call_method_asynchronously);
1997 defsubr (&Sdbus_call_method_asynchronously);
1998
1999 Qdbus_method_return_internal = intern_c_string ("dbus-method-return-internal");
2000 staticpro (&Qdbus_method_return_internal);
2001 defsubr (&Sdbus_method_return_internal);
2002
2003 Qdbus_method_error_internal = intern_c_string ("dbus-method-error-internal");
2004 staticpro (&Qdbus_method_error_internal);
2005 defsubr (&Sdbus_method_error_internal);
2006
2007 Qdbus_send_signal = intern_c_string ("dbus-send-signal");
2008 staticpro (&Qdbus_send_signal);
2009 defsubr (&Sdbus_send_signal);
2010
2011 Qdbus_register_signal = intern_c_string ("dbus-register-signal");
2012 staticpro (&Qdbus_register_signal);
2013 defsubr (&Sdbus_register_signal);
2014
2015 Qdbus_register_method = intern_c_string ("dbus-register-method");
2016 staticpro (&Qdbus_register_method);
2017 defsubr (&Sdbus_register_method);
2018
2019 Qdbus_error = intern_c_string ("dbus-error");
2020 staticpro (&Qdbus_error);
2021 Fput (Qdbus_error, Qerror_conditions,
2022 list2 (Qdbus_error, Qerror));
2023 Fput (Qdbus_error, Qerror_message,
2024 make_pure_c_string ("D-Bus error"));
2025
2026 QCdbus_system_bus = intern_c_string (":system");
2027 staticpro (&QCdbus_system_bus);
2028
2029 QCdbus_session_bus = intern_c_string (":session");
2030 staticpro (&QCdbus_session_bus);
2031
2032 QCdbus_timeout = intern_c_string (":timeout");
2033 staticpro (&QCdbus_timeout);
2034
2035 QCdbus_type_byte = intern_c_string (":byte");
2036 staticpro (&QCdbus_type_byte);
2037
2038 QCdbus_type_boolean = intern_c_string (":boolean");
2039 staticpro (&QCdbus_type_boolean);
2040
2041 QCdbus_type_int16 = intern_c_string (":int16");
2042 staticpro (&QCdbus_type_int16);
2043
2044 QCdbus_type_uint16 = intern_c_string (":uint16");
2045 staticpro (&QCdbus_type_uint16);
2046
2047 QCdbus_type_int32 = intern_c_string (":int32");
2048 staticpro (&QCdbus_type_int32);
2049
2050 QCdbus_type_uint32 = intern_c_string (":uint32");
2051 staticpro (&QCdbus_type_uint32);
2052
2053 QCdbus_type_int64 = intern_c_string (":int64");
2054 staticpro (&QCdbus_type_int64);
2055
2056 QCdbus_type_uint64 = intern_c_string (":uint64");
2057 staticpro (&QCdbus_type_uint64);
2058
2059 QCdbus_type_double = intern_c_string (":double");
2060 staticpro (&QCdbus_type_double);
2061
2062 QCdbus_type_string = intern_c_string (":string");
2063 staticpro (&QCdbus_type_string);
2064
2065 QCdbus_type_object_path = intern_c_string (":object-path");
2066 staticpro (&QCdbus_type_object_path);
2067
2068 QCdbus_type_signature = intern_c_string (":signature");
2069 staticpro (&QCdbus_type_signature);
2070
2071 QCdbus_type_array = intern_c_string (":array");
2072 staticpro (&QCdbus_type_array);
2073
2074 QCdbus_type_variant = intern_c_string (":variant");
2075 staticpro (&QCdbus_type_variant);
2076
2077 QCdbus_type_struct = intern_c_string (":struct");
2078 staticpro (&QCdbus_type_struct);
2079
2080 QCdbus_type_dict_entry = intern_c_string (":dict-entry");
2081 staticpro (&QCdbus_type_dict_entry);
2082
2083 DEFVAR_LISP ("dbus-registered-objects-table",
2084 &Vdbus_registered_objects_table,
2085 doc: /* Hash table of registered functions for D-Bus.
2086 There are two different uses of the hash table: for accessing
2087 registered interfaces properties, targeted by signals or method calls,
2088 and for calling handlers in case of non-blocking method call returns.
2089
2090 In the first case, the key in the hash table is the list (BUS
2091 INTERFACE MEMBER). BUS is either the symbol `:system' or the symbol
2092 `:session'. INTERFACE is a string which denotes a D-Bus interface,
2093 and MEMBER, also a string, is either a method, a signal or a property
2094 INTERFACE is offering. All arguments but BUS must not be nil.
2095
2096 The value in the hash table is a list of quadruple lists
2097 \((UNAME SERVICE PATH OBJECT) (UNAME SERVICE PATH OBJECT) ...).
2098 SERVICE is the service name as registered, UNAME is the corresponding
2099 unique name. In case of registered methods and properties, UNAME is
2100 nil. PATH is the object path of the sending object. All of them can
2101 be nil, which means a wildcard then. OBJECT is either the handler to
2102 be called when a D-Bus message, which matches the key criteria,
2103 arrives (methods and signals), or a cons cell containing the value of
2104 the property.
2105
2106 In the second case, the key in the hash table is the list (BUS SERIAL).
2107 BUS is either the symbol `:system' or the symbol `:session'. SERIAL
2108 is the serial number of the non-blocking method call, a reply is
2109 expected. Both arguments must not be nil. The value in the hash
2110 table is HANDLER, the function to be called when the D-Bus reply
2111 message arrives. */);
2112 /* We initialize Vdbus_registered_objects_table in dbus.el, because
2113 we need to define a hash table function first. */
2114 Vdbus_registered_objects_table = Qnil;
2115
2116 DEFVAR_LISP ("dbus-debug", &Vdbus_debug,
2117 doc: /* If non-nil, debug messages of D-Bus bindings are raised. */);
2118 #ifdef DBUS_DEBUG
2119 Vdbus_debug = Qt;
2120 #else
2121 Vdbus_debug = Qnil;
2122 #endif
2123
2124 Fprovide (intern_c_string ("dbusbind"), Qnil);
2125
2126 }
2127
2128 #endif /* HAVE_DBUS */
2129
2130 /* arch-tag: 0e828477-b571-4fe4-b559-5c9211bc14b8
2131 (do not change this comment) */
Unnamed repository; edit this file 'description' to name the repository.