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