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