Context Navigation

source: project/release/4/dbus/trunk/dbus.scm @ 25880

Last change on this file since 25880 was 25880, checked in by ecloud, 9 years ago

Added support for dict and variant and a connman introspection example.

Not sure if the variant support is quite right, because what's inside
is often unsupported.

File size: 27.8 KB

Line
1	;;;; dbus.scm
2
3	(module dbus (dbus:make-context
4	dbus:send
5	dbus:call
6	dbus:make-method-proxy
7	dbus:register-signal-handler
8	dbus:register-method
9	dbus:enable-polling-thread!
10	dbus:poll-for-message
11	dbus:discover-services
12	dbus:discover-api-xml
13	dbus:dbus-service
14	dbus:type-uint32
15	dbus:session-bus
16	dbus:system-bus
17	dbus:starter-bus
18	dbus:known-bus-count
19	dbus:register-path)
20	(import scheme chicken
21	(except foreign foreign-declare)
22	foreigners
23	easyffi
24	miscmacros)
25	(use srfi-18)
26
27
28	#>
29	#include <dbus/dbus.h>
30	#include <stdbool.h>
31	#include <stdint.h>
32	#include <fcntl.h>
33	#include <unistd.h>
34
35	static DBusError err;
36	<#
37
38	; Would want to do this:
39	; (define-foreign-enum (dbus:bus (enum "DBusBusType"))
40	; (dbus:session-bus DBUS_BUS_SESSION)
41	; (dbus:system-bus DBUS_BUS_SYSTEM)
42	; (dbus:starter-bus DBUS_BUS_STARTER) )
43	; but because that enum is typedef'd, chicken has a problem with it.
44
45	(define-foreign-type dbus:bus int) ; really "DBusBusType"
46	(define dbus:session-bus (foreign-value DBUS_BUS_SESSION int))
47	(define dbus:system-bus (foreign-value DBUS_BUS_SYSTEM int))
48	(define dbus:starter-bus (foreign-value DBUS_BUS_STARTER int))
49	(define dbus:dbus-service (foreign-value DBUS_SERVICE_DBUS c-string))
50	(define dbus:known-bus-count (+ 1 (max dbus:session-bus dbus:system-bus dbus:starter-bus)))
51
52	(define-foreign-type dbus:handler-result int) ; really "DBusHandlerResult"
53	(define dbus:result-handled (foreign-value DBUS_HANDLER_RESULT_HANDLED int))
54	(define dbus:result-not-yet-handled (foreign-value DBUS_HANDLER_RESULT_NOT_YET_HANDLED int))
55	(define dbus:result-need-memory (foreign-value DBUS_HANDLER_RESULT_NEED_MEMORY int))
56
57	(define dbus:name-flag-allow-replacement (foreign-value DBUS_NAME_FLAG_ALLOW_REPLACEMENT int))
58	(define dbus:name-flag-replace-existing (foreign-value DBUS_NAME_FLAG_REPLACE_EXISTING int))
59	(define dbus:name-flag-do-not-queue (foreign-value DBUS_NAME_FLAG_DO_NOT_QUEUE int))
60
61	;; DBus simple data types
62	(define dbus:type-invalid (foreign-value DBUS_TYPE_INVALID int))
63	(define dbus:type-invalid-string (foreign-value DBUS_TYPE_INVALID_AS_STRING int))
64	(define dbus:type-byte (foreign-value DBUS_TYPE_BYTE int))
65	(define dbus:type-byte-string (foreign-value DBUS_TYPE_BYTE_AS_STRING int))
66	(define dbus:type-boolean (foreign-value DBUS_TYPE_BOOLEAN int))
67	(define dbus:type-boolean-string (foreign-value DBUS_TYPE_BOOLEAN_AS_STRING int))
68	(define dbus:type-int16 (foreign-value DBUS_TYPE_INT16 int))
69	(define dbus:type-int16-string (foreign-value DBUS_TYPE_INT16_AS_STRING int))
70	(define dbus:type-uint16 (foreign-value DBUS_TYPE_UINT16 int))
71	(define dbus:type-uint16-string (foreign-value DBUS_TYPE_UINT16_AS_STRING int))
72	(define dbus:type-fixnum (foreign-value DBUS_TYPE_INT32 int))
73	(define dbus:type-int32 (foreign-value DBUS_TYPE_INT32 int))
74	(define dbus:type-int32-string (foreign-value DBUS_TYPE_INT32_AS_STRING int))
75	(define dbus:type-uint32 (foreign-value DBUS_TYPE_UINT32 int))
76	(define dbus:type-uint32-string (foreign-value DBUS_TYPE_UINT32_AS_STRING int))
77	(define dbus:type-int64 (foreign-value DBUS_TYPE_INT64 int))
78	(define dbus:type-int64-string (foreign-value DBUS_TYPE_INT64_AS_STRING int))
79	(define dbus:type-uint64 (foreign-value DBUS_TYPE_UINT64 int))
80	(define dbus:type-uint64-string (foreign-value DBUS_TYPE_UINT64_AS_STRING int))
81	(define dbus:type-double (foreign-value DBUS_TYPE_DOUBLE int))
82	(define dbus:type-flonum (foreign-value DBUS_TYPE_DOUBLE int))
83	(define dbus:type-double-string (foreign-value DBUS_TYPE_DOUBLE_AS_STRING int))
84	(define dbus:type-string (foreign-value DBUS_TYPE_STRING int))
85	(define dbus:type-string-string (foreign-value DBUS_TYPE_STRING_AS_STRING int))
86	(define dbus:type-object-path (foreign-value DBUS_TYPE_OBJECT_PATH int))
87	(define dbus:type-signature (foreign-value DBUS_TYPE_SIGNATURE int))
88	(define dbus:type-signature-string (foreign-value DBUS_TYPE_SIGNATURE_AS_STRING int))
89	(define dbus:type-array (foreign-value DBUS_TYPE_ARRAY int))
90	(define dbus:type-array-string (foreign-value DBUS_TYPE_ARRAY_AS_STRING int))
91	(define dbus:type-dict (foreign-value DBUS_TYPE_DICT_ENTRY int))
92	(define dbus:type-variant (foreign-value DBUS_TYPE_VARIANT int))
93
94	(define dbus:make-context)
95	(define dbus:send)
96	(define dbus:make-method-proxy)
97	(define dbus:call)
98	(define dbus:flush)
99	(define dbus:poll-for-message)
100	(define dbus:register-signal-handler)
101	(define dbus:register-method)
102	(define dbus:register-path)
103	(define dbus:enable-polling-thread!)
104
105	(define dbus:add-match)
106	(define dbus:request-name)
107
108
109	(define find-callback)
110
111	(define-foreign-type error-ptr c-pointer) ;; DBusError*
112	(define-foreign-type connection-ptr c-pointer) ;; DBusConnection*
113	(define-foreign-type message-ptr c-pointer) ;; DBusMessage*
114	(define-foreign-type uint-ptr c-pointer) ;; dbus_uint32_t*
115	(define-foreign-type message-iter-ptr c-pointer) ;; DBusMessageIter*
116	(define-foreign-type vtable-ptr c-pointer) ;; DBusObjectPathVTable*
117
118	(define (dbus:discover-services #!key (bus dbus:session-bus))
119	(let* ([ctxt (dbus:make-context
120	bus: bus
121	service: 'org.freedesktop.DBus
122	interface: 'org.freedesktop.DBus
123	path: '/org/freedesktop/DBus)]
124	[services (dbus:call ctxt "ListNames")])
125	(and (pair? services) (vector? (car services)) (vector->list (car services)))))
126
127	(define dbus:discover-api-xml)
128
129	(define-external (C_msg_cb (dbus:bus bus) (message-ptr msg)) bool
130	(let* ([cb (find-callback bus msg)][found (procedure? cb)])
131	; (printf "got a message: ~s on bus ~a and found callback ~s~%" msg bus cb)
132	(when found
133	(cb msg))
134	found
135	))
136
137	(let ( [connections '()] ;; an alist mapping dbus:bus to DBusConnection ptrs
138	[error (foreign-value "&err" c-pointer)]
139	;; indices in a "context" vector
140	[context-idx-ID 0]
141	[context-idx-bus 1]
142	[context-idx-service 2]
143	[context-idx-path 3]
144	[context-idx-interface 4]
145	[context-count 0]
146	[default-polling-interval 0.01]
147	[polling-interval (make-vector dbus:known-bus-count 0.01)]
148	[polling-enabled (make-vector dbus:known-bus-count #t)]
149	[polling-threads (make-vector dbus:known-bus-count #f)]
150	;; will become an assoc tree:
151	;; bus
152	;; path
153	;; service (unless it's a signal callback)
154	;; interface
155	;; method
156	;; callback-fn
157	[callbacks-table `((,dbus:system-bus . #f) (,dbus:session-bus . #f))]
158	[iterm (gensym 'terminiter)] )
159
160	(define (any->string arg)
161	(if (string? arg)
162	arg
163	(if (eq? (void) arg)
164	""
165	(format "~a" arg)
166	)))
167
168	(define (symbol?->string arg)
169	(if (symbol? arg)
170	(symbol->string arg)
171	arg))
172
173	(define (string?->symbol arg)
174	(if (string? arg)
175	(string->symbol arg)
176	arg))
177
178	;; If the assq-list has the given key, replace its value.
179	;; Else add the key-value pair.
180	(define (asset! alist key val)
181	(let ([pr (assq key alist)])
182	(if pr
183	(set-cdr! pr val)
184	(if (null? (cdar alist))
185	(set-car! alist (cons key val))
186	(begin
187	(set-cdr! alist (cons (car alist) (cdr alist)))
188	(set-car! alist (cons key val))) ))))
189
190	;; The "tree" version of assq: drills down into an assq-tree
191	;; as directed by the sequence of keys, and returns the value found.
192	;; #f means not found (so it is not useful to store #f in such a tree).
193	(define (tassq tree . keys)
194	(let ([key-list (if (pair? (car keys)) (car keys) keys)])
195	(let loop ([rem-keys key-list][subtree tree])
196	(if (null? rem-keys)
197	subtree
198	(loop (cdr rem-keys)
199	(let ([pr (assq (car rem-keys) subtree)])
200	(and (pair? pr) (cdr pr))))))))
201
202	;; The "tree" version of asset!: drills down into an assq-tree
203	;; as directed by the sequence of keys, making new branches as necessary,
204	;; and sets the given value as a leaf at that point in the tree.
205	;; return value is undefined
206	(define (tasset! tree val . keys)
207	(let ([key-list (if (pair? (car keys)) (car keys) keys)])
208	(let loop ( [rem-keys (cdr key-list)]
209	[subtree (tassq tree (car key-list))]
210	[prev-key (car key-list)]
211	[prev-subtree tree])
212	; (printf "rem-keys ~s subtree ~s prev-key ~s prev-subtree ~s~%" rem-keys subtree prev-key prev-subtree)
213	(when (and (not subtree) (pair? rem-keys))
214	(set! subtree (list (cons (car rem-keys) #f)))
215	; (printf " creating subtree ~s within ~s~%" subtree prev-subtree)
216	(asset! prev-subtree prev-key subtree)
217	; (pretty-print prev-subtree)
218	)
219	(if (null? rem-keys)
220	(asset! prev-subtree prev-key val)
221	(loop
222	(cdr rem-keys)
223	(let ([pr (assq (car rem-keys) subtree)])
224	(unless (pair? pr)
225	(set! pr (cons (car rem-keys) #f))
226	(set-cdr! subtree (cons (car subtree) (cdr subtree)))
227	(set-car! subtree pr) )
228	(cdr pr))
229	(car rem-keys)
230	subtree )))))
231
232	(define (next-context-ID) (set! context-count (+ 1 context-count)) context-count)
233
234	(define (get-conn bus-type)
235	(let ([conn (assq bus-type connections)])
236	(if (pair? conn)
237	(set! conn (cdr conn))
238	(begin
239	(set! conn ((foreign-lambda connection-ptr "dbus_bus_get" dbus:bus error-ptr)
240	bus-type error) )
241	(when conn
242	(set! connections (cons (cons bus-type conn) connections)))))
243	conn))
244
245	(define (conn-or-abort bus-type)
246	(or (get-conn bus-type)
247	(abort (format "unable to connect to bus ~s~%" bus-type))))
248
249	(define (exists-or-abort datum err-str)
250	(or datum
251	(abort err-str)))
252
253	;; params: path interface name
254	;; todo: garbage-collect this
255	(define make-signal (foreign-lambda message-ptr "dbus_message_new_signal"
256	c-string c-string c-string))
257
258	;; params: service path interface method-name
259	;; todo: garbage-collect this
260	(define make-message (foreign-lambda message-ptr "dbus_message_new_method_call"
261	c-string c-string c-string c-string))
262
263	;; todo: garbage-collect this
264	(define make-iter-append
265	(foreign-lambda* message-iter-ptr ((message-ptr msg))
266	"DBusMessageIter* iter = malloc(sizeof(DBusMessageIter));
267	dbus_message_iter_init_append (msg, iter);
268	C_return (iter);"))
269
270	(define iter-append-basic-string
271	(foreign-lambda* bool ((message-iter-ptr iter) (c-string v))
272	"C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_STRING, &v));"))
273
274	(define iter-append-basic-bool
275	(foreign-lambda* bool ((message-iter-ptr iter) (bool v))
276	"C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_BOOLEAN, &v));"))
277
278	(define iter-append-basic-int
279	(foreign-lambda* bool ((message-iter-ptr iter) (int v))
280	"C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_INT32, &v));"))
281
282	(define iter-append-basic-double
283	(foreign-lambda* bool ((message-iter-ptr iter) (double v))
284	"C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_DOUBLE, &v));"))
285
286	(define iter-append-basic-byte
287	(foreign-lambda* bool ((message-iter-ptr iter) (int v))
288	"C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_BYTE, &v));"))
289
290	(define iter-append-basic-int16
291	(foreign-lambda* bool ((message-iter-ptr iter) (int v))
292	"C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_INT16, &v));"))
293
294	(define iter-append-basic-uint32
295	(foreign-lambda* bool ((message-iter-ptr iter) (unsigned-integer32 v))
296	"C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_UINT32, &v));"))
297
298	(define iter-append-basic-uint16
299	(foreign-lambda* bool ((message-iter-ptr iter) (unsigned-short v))
300	"C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_UINT16, &v));"))
301
302	(define iter-append-basic-int64
303	(foreign-lambda* bool ((message-iter-ptr iter) (integer64 v))
304	"C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_INT64, &v));"))
305
306	(define iter-append-basic-uint64
307	(foreign-lambda* bool ((message-iter-ptr iter) (integer64 v))
308	"C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_UINT64, &v));"))
309
310	;; TODO: iter-append-basic-T for each possible type:
311	;; especially variant, array and struct might still be possible
312
313	;; val would usually be a single value, but
314	;; could be a pair of the form (dbus:type-x . value)
315	;; in which case we will attempt to convert the value to that type for sending.
316	(define (iter-append-basic iter val)
317	(cond
318	[(fixnum? val) (iter-append-basic-int iter val)]
319	[(flonum? val) (iter-append-basic-double iter val)]
320	[(boolean? val) (iter-append-basic-bool iter val)]
321	[(pair? val)
322	(let ([type (car val)])
323	(cond
324	;; TODO: this doesn't compile
325	;; Error: Arguments to inlined call of `iter-append-basic-byte'
326	;; do not match parameter-list (a207 a206)
327	;; so I guess it has to _be_ a byte before the call
328	; [(eq? type dbus:type-byte)
329	; (iter-append-basic-byte (cdr val))]
330	; [(eq? type dbus:type-int16)
331	; (iter-append-basic-int16 (cdr val))]
332	; [(eq? type dbus:type-uint32)
333	; (iter-append-basic-uint32 (cdr val))]
334	; [(eq? type dbus:type-uint16)
335	; (iter-append-basic-uint16 (cdr val))]
336	; [(eq? type dbus:type-int64)
337	; (iter-append-basic-int64 (cdr val))]
338	; [(eq? type dbus:type-uint64)
339	; (iter-append-basic-uint64 (cdr val))]
340	;; other custom requests will be handled as usual, above
341	[else (iter-append-basic iter (cdr val))] ))]
342	[else (iter-append-basic-string iter (any->string val))] ))
343
344	(define free-iter (foreign-lambda* void ((message-iter-ptr i)) "free(i);"))
345
346	(define (iter-cond iter)
347	(let ( [type ((foreign-lambda int "dbus_message_iter_get_arg_type"
348	message-iter-ptr) iter)] )
349	(cond
350	[(memq type `(,dbus:type-string ,dbus:type-invalid-string
351	,dbus:type-string-string ,dbus:type-object-path
352	,dbus:type-signature-string
353	;; TODO maybe the following types ought to be converted?
354	,dbus:type-byte-string ,dbus:type-boolean-string
355	,dbus:type-int16-string ,dbus:type-uint16-string
356	,dbus:type-int32-string ,dbus:type-uint32-string
357	,dbus:type-int64-string ,dbus:type-uint64-string
358	,dbus:type-double-string ))
359	((foreign-lambda* c-string ((message-iter-ptr iter))
360	"char* ret;
361	dbus_message_iter_get_basic(iter, &ret);
362	C_return (ret);") iter)]
363	[(eq? type dbus:type-boolean)
364	((foreign-lambda* bool ((message-iter-ptr iter))
365	"bool ret;
366	dbus_message_iter_get_basic(iter, &ret);
367	return (ret);") iter)]
368	[(memq type `(,dbus:type-int32 ,dbus:type-byte
369	,dbus:type-int16 ))
370	((foreign-lambda* int ((message-iter-ptr iter))
371	"int ret;
372	dbus_message_iter_get_basic(iter, &ret);
373	C_return (ret);") iter)]
374	[(memq type `(,dbus:type-uint32 ,dbus:type-uint16))
375	((foreign-lambda* unsigned-int ((message-iter-ptr iter))
376	"unsigned int ret;
377	dbus_message_iter_get_basic(iter, &ret);
378	C_return (ret);") iter)]
379	[(memq type `(,dbus:type-flonum ,dbus:type-uint64))
380	((foreign-lambda* double ((message-iter-ptr iter))
381	"double ret;
382	dbus_message_iter_get_basic(iter, &ret);
383	C_return (ret);") iter)]
384	[(eq? type dbus:type-int64)
385	((foreign-lambda* integer64 ((message-iter-ptr iter))
386	"int64_t ret;
387	dbus_message_iter_get_basic(iter, &ret);
388	C_return (ret);") iter)]
389	[(eq? type dbus:type-array)
390	(iter->vector (make-sub-iter iter))]
391	[(eq? type dbus:type-dict)
392	(iter->pair (make-sub-iter iter))]
393	[(eq? type dbus:type-variant)
394	((make-sub-iter iter))]
395	;; unsupported so far (not understood well enough):
396	;; dbus:type-object-path and dbus:type-signature
397	;; dbus:type-invalid is returned as #f (could be (void) but that
398	;; would be the termination condition for the iterator)
399	;[else (format "unsupported-~c" (integer->char type))] )))
400	[else #f] )))
401
402	(define (make-sub-iter iter)
403	(let* ([sub ((foreign-lambda* message-iter-ptr ((message-iter-ptr iter))
404	"DBusMessageIter* i = malloc(sizeof(DBusMessageIter));
405	dbus_message_iter_recurse(iter, i);
406	C_return (i);") iter) ]
407	[has-next sub]
408	)
409	(lambda ()
410	(if has-next
411	(let ([ret (iter-cond sub)])
412	(set! has-next ((foreign-lambda bool
413	"dbus_message_iter_next" message-iter-ptr) sub))
414	ret )
415	(begin
416	(free-iter sub)
417	iterm)
418	))))
419
420	;; iterator for reading parameters from a message
421	;; returns a lambda which provides one param at a time, terminating with (void)
422	(define (make-iter msg)
423	(let* ([iter ((foreign-lambda* message-iter-ptr ((message-ptr msg))
424	"DBusMessageIter* i = malloc(sizeof(DBusMessageIter));
425	if (!dbus_message_iter_init (msg, i))
426	i = (DBusMessageIter*)0; // Message has no parameters
427	C_return (i);") msg) ]
428	[has-next iter]
429	)
430	(lambda ()
431	(if has-next
432	(let ([ret (iter-cond iter)])
433	(set! has-next ((foreign-lambda bool
434	"dbus_message_iter_next" message-iter-ptr) iter))
435	ret )
436	(begin
437	(free-iter iter)
438	iterm)
439	))))
440
441	;; todo maybe: rewrite to avoid the reverse
442	(define (iter->list iter)
443	(let loop ([retval '()])
444	(let ([next (iter)])
445	(if (eq? next iterm)
446	(reverse retval)
447	(loop (cons next retval))))))
448
449	(define (iter->pair iter)
450	(cons (iter) (iter)))
451
452	(define (iter->vector iter)
453	(let ([l (iter->list iter)])
454	(list->vector l)))
455
456	(define msg-path
457	(foreign-lambda c-string "dbus_message_get_path" message-ptr))
458
459	(define msg-interface
460	(foreign-lambda c-string "dbus_message_get_interface" message-ptr))
461
462	(define msg-member
463	(foreign-lambda c-string "dbus_message_get_member" message-ptr))
464
465	(define msg-error-name
466	(foreign-lambda c-string "dbus_message_get_error_name" message-ptr))
467
468	(define msg-service
469	(foreign-lambda c-string "dbus_message_get_destination" message-ptr))
470
471	(set! find-callback (lambda (bus msg)
472	(let ([path (string?->symbol (msg-path msg))]
473	[iface (string?->symbol (msg-interface msg))]
474	[mber (string?->symbol (msg-member msg))]
475	[svc (string?->symbol (msg-service msg))]
476	)
477	; (printf " svc ~s~%" svc)
478	; (printf " path ~s~%" path)
479	; (printf " iface ~s~%" iface)
480	; (printf " mber ~s~%" mber)
481	;; The service name is not included as part of the signal, so svc will be #f.
482	;; In that case the callback is registered under bus/path/iface/signal-name.
483	(if svc
484	(tassq callbacks-table bus path svc iface mber)
485	(tassq callbacks-table bus path iface mber) ))))
486
487	(set! dbus:make-context (lambda (#!key (bus dbus:session-bus) service interface (path "/"))
488	(vector (next-context-ID) bus (string?->symbol service)
489	(string?->symbol path) (string?->symbol interface)) ))
490
491	(define send-impl
492	(foreign-lambda int "dbus_connection_send" connection-ptr message-ptr uint-ptr))
493
494	(set! dbus:send (lambda (context name . params)
495	(let* ( [service (symbol?->string (vector-ref context context-idx-service))]
496	[msg (make-signal
497	(symbol?->string (vector-ref context context-idx-path))
498	(symbol?->string (vector-ref context context-idx-interface))
499	name)]
500	[iter (make-iter-append msg)] )
501	(let ([conn (conn-or-abort (vector-ref context context-idx-bus))])
502	; (exists-or-abort conn (format "no connection to bus ~s~%" (vector-ref context context-idx-bus)))
503	(for-each (lambda (parm)
504	(iter-append-basic iter parm)) params)
505	(send-impl conn msg #f)
506	(free-iter iter)
507	; ((foreign-lambda void "dbus_connection_flush" connection-ptr) conn)
508	))))
509
510	(set! dbus:call (lambda (context name . params)
511	(let* ( [service (symbol->string (vector-ref context context-idx-service))]
512	[msg (make-message service
513	(symbol->string (vector-ref context context-idx-path))
514	(symbol->string (vector-ref context context-idx-interface))
515	name)]
516	[iter (make-iter-append msg)] )
517	(let ([conn (conn-or-abort (vector-ref context context-idx-bus))])
518	; (exists-or-abort conn (format "no connection to bus ~s~%" (vector-ref context context-idx-bus)))
519	(for-each (lambda (parm)
520	(iter-append-basic iter parm)) params)
521	(free-iter iter)
522	(let* ( [reply-msg ((foreign-lambda* message-ptr ((connection-ptr conn) (message-ptr msg))
523	;; idealistic code here; todo: error checking
524	;; todo: timeout comes from where? (make-parameter) maybe
525	"DBusMessage *reply;
526	DBusError error;
527	dbus_error_init (&error);
528	reply = dbus_connection_send_with_reply_and_block(conn, msg, 5000, &error);
529	if (dbus_error_is_set (&error))
530	fprintf (stderr, \"Error %s: %s\\n\", error.name, error.message);
531	dbus_message_unref(msg);
532	C_return(reply);") conn msg) ]
533	[reply-iter (make-iter reply-msg)]
534	[reply-args (iter->list reply-iter)] )
535	reply-args)))))
536
537	(set! dbus:make-method-proxy (lambda (context name)
538	(let ( [service (symbol->string (vector-ref context context-idx-service))]
539	[conn (conn-or-abort (vector-ref context context-idx-bus))] )
540	; (exists-or-abort conn (format "no connection to bus ~s~%" (vector-ref context context-idx-bus)))
541	(lambda params
542	(let* ( [msg (make-message service
543	(symbol->string (vector-ref context context-idx-path))
544	(symbol->string (vector-ref context context-idx-interface))
545	name)]
546	[iter (make-iter-append msg)] )
547	(for-each (lambda (parm)
548	(iter-append-basic iter parm)) params)
549	(free-iter iter)
550	;; TODO: pull this out into a helper function
551	(let* ( [reply-msg ((foreign-lambda* message-ptr ((connection-ptr conn) (message-ptr msg))
552	;; idealistic code here; todo: error checking
553	"DBusPendingCall* pending;
554	dbus_connection_send_with_reply(conn, msg, &pending, -1);
555	dbus_connection_flush(conn);
556	dbus_message_unref(msg);
557	dbus_pending_call_block(pending);
558	msg = dbus_pending_call_steal_reply(pending);
559	C_return(msg);") conn msg) ]
560	[reply-iter (make-iter reply-msg)]
561	[reply-args (iter->list reply-iter)] )
562	reply-args))))))
563
564	(define-foreign-record-type (dbus:vtable "struct DBusObjectPathVTable")
565	(constructor: dbus:make-vtable-impl)
566	(destructor: dbus:free-vtable)
567	(c-pointer unregister_function dbus:vtable-unregister_function dbus:vtable-unregister_function-set!)
568	(c-pointer message_function dbus:vtable-message_function dbus:vtable-message_function-set!)
569	(c-pointer dbus_internal_pad1 dbus:vtable-dbus_internal_pad1)
570	(c-pointer dbus_internal_pad2 dbus:vtable-dbus_internal_pad2)
571	(c-pointer dbus_internal_pad3 dbus:vtable-dbus_internal_pad3)
572	(c-pointer dbus_internal_pad4 dbus:vtable-dbus_internal_pad4))
573
574	(define (dbus:make-vtable cb unreg-cb)
575	(let ()
576	(define (fn conn msg user-data)
577	; (printf "fixin' to call ~a with ~a, ~a, ~a~%" cb conn msg user-data)
578	(let ([ret (cb conn msg user-data)])
579	;; TODO: return ret as the result
580	dbus:result-handled ))
581	(let ([ret (dbus:make-vtable-impl)])
582	(dbus:vtable-message_function-set! ret fn)
583	(dbus:vtable-unregister_function-set! ret unreg-cb)
584	ret) ))
585
586	; (set! dbus:add-match-self (lambda ()
587	; ((foreign-safe-lambda void "dbus_bus_add_match" connection-ptr c-string error-ptr)
588	; (get-conn (vector-ref context context-idx-bus)) rule #f) ))
589
590	(set! dbus:read-write (lambda (conn timeout)
591	(let ()
592	((foreign-safe-lambda bool "dbus_connection_read_write" connection-ptr int)
593	conn timeout))))
594
595	(set! dbus:request-name (lambda (context)
596	(let ([service-name (symbol?->string (vector-ref context context-idx-service))])
597	(conn-or-abort (vector-ref context context-idx-bus))
598	(when service-name
599	((foreign-safe-lambda void "dbus_bus_request_name" connection-ptr c-string int error-ptr)
600	(get-conn (vector-ref context context-idx-bus))
601	service-name
602	dbus:name-flag-replace-existing #f) ))))
603
604	(set! dbus:add-match (lambda (context)
605	;; TODO is it always type signal? We are using this for methods too.
606	(let ([rule (format "type='signal', interface='~s'" (vector-ref context context-idx-interface))])
607	(conn-or-abort (vector-ref context context-idx-bus))
608	((foreign-safe-lambda void "dbus_bus_add_match" connection-ptr c-string error-ptr)
609	(get-conn (vector-ref context context-idx-bus)) rule #f) )))
610
611	;; return #t if it received a message, #f if not
612	(set! dbus:poll-for-message (lambda (#!key (bus dbus:session-bus) (timeout 0))
613	(let ([conn (conn-or-abort bus)])
614	; (exists-or-abort conn (format "no connection to bus ~s~%" (vector-ref context context-idx-bus)))
615	((foreign-safe-lambda* bool
616	((connection-ptr conn) (dbus:bus bus) (int timeout))
617	"DBusMessage* msg = NULL;
618	dbus_connection_read_write(conn, timeout);
619	msg = dbus_connection_pop_message(conn);
620	if (msg)
621	{
622	//printf(\"rcv: %s\\n\", dbus_message_get_interface(msg));
623	C_msg_cb(bus, msg);
624	dbus_message_unref(msg);
625	C_return(true); // yes there was a message
626	}
627	C_return (false); // we polled, we came back empty-handed
628	") conn bus timeout)
629	)))
630
631	;; TODO: one polling thread is necessary for each connection
632	(define (dbus:start-polling! bus interval)
633	(vector-set! polling-interval bus interval)
634	; (pretty-print callbacks-table)
635	(when (vector-ref polling-enabled bus)
636	(unless (vector-ref polling-threads bus)
637	(vector-set! polling-threads bus (thread-start! (lambda ()
638	(let loop ()
639	; (printf "polling~%")
640	(dbus:poll-for-message bus: bus timeout: 0)
641	(thread-sleep! (vector-ref polling-interval bus))
642	(when (vector-ref polling-enabled bus) (loop)))))))))
643
644	(set! dbus:enable-polling-thread! (lambda (#!key (bus dbus:session-bus) (enable #t) (interval default-polling-interval))
645	(vector-set! polling-enabled bus enable)
646	(if enable
647	(dbus:start-polling! bus interval)
648	(let ([th (vector-ref polling-threads bus)])
649	(when th (thread-join! th))))))
650
651	;; Wraps a user-provided callback so as to pass it the
652	;; received dbus message's parameters, and return a dbus response
653	;; with the parameter(s) returned from the callback.
654	;; msg-cb is the user-provided one.
655	(define (method-wrapper conn msg-cb)
656	(lambda (msg)
657	(let ( [args (iter->list (make-iter msg))]
658	[response ((foreign-lambda message-ptr
659	"dbus_message_new_method_return" message-ptr) msg)])
660	(let ( [ret (apply msg-cb args)]
661	[iter (make-iter-append response)] )
662	(if (pair? ret)
663	(for-each (lambda (parm)
664	; (printf "appending return parameter ~s~%" parm)
665	(iter-append-basic iter parm)) ret)
666	(iter-append-basic iter ret))
667	;; send response
668	(send-impl conn response #f)
669	(free-iter iter)
670	))))
671
672	(define (handler-wrapper conn msg-cb)
673	(lambda (msg)
674	(let ([args (iter->list (make-iter msg))])
675	(apply msg-cb args) )))
676
677	;; msg-cb: the handler implementation. Its return value is ignored.
678	(set! dbus:register-signal-handler (lambda (context name msg-cb)
679	(dbus:request-name context)
680	(dbus:add-match context)
681	(tasset! callbacks-table
682	(handler-wrapper (conn-or-abort (vector-ref context context-idx-bus)) msg-cb)
683	(vector-ref context context-idx-bus)
684	(vector-ref context context-idx-path)
685	(vector-ref context context-idx-interface)
686	(string?->symbol name))
687	(dbus:start-polling! (vector-ref context context-idx-bus) default-polling-interval)
688	))
689
690	;; msg-cb: the method implementation. Its return value is sent back as the response.
691	(set! dbus:register-method (lambda (context name msg-cb)
692	(dbus:request-name context)
693	; (dbus:add-match context) doesn't seem to be necessary
694	(tasset! callbacks-table
695	(method-wrapper (conn-or-abort (vector-ref context context-idx-bus)) msg-cb)
696	(vector-ref context context-idx-bus)
697	(vector-ref context context-idx-path)
698	(vector-ref context context-idx-service)
699	(vector-ref context context-idx-interface)
700	(string?->symbol name))
701	(dbus:start-polling! (vector-ref context context-idx-bus) default-polling-interval)
702	))
703
704	; dbus_bool_t dbus_connection_register_object_path (DBusConnection *connection,
705	; const char *path,
706	; const DBusObjectPathVTable *vtable,
707	; void *user_data);
708	(set! dbus:register-path (lambda (bus path fn unreg-fn)
709	; (let ([unreg-fn (lambda (parm . rest) #f)])
710	((foreign-safe-lambda bool "dbus_connection_register_object_path"
711	connection-ptr c-string vtable-ptr c-pointer)
712	(conn-or-abort bus)
713	(symbol?->string path)
714	(dbus:make-vtable fn unreg-fn) #f)))
715
716	(set! dbus:discover-api-xml (lambda (ctxt)
717	(let ([ctxt (list->vector (vector->list ctxt))]) ;; todo: efficiency?
718	(vector-set! ctxt context-idx-interface 'org.freedesktop.DBus.Introspectable)
719	(let ([xml (dbus:call ctxt "Introspect")])
720	(and (pair? xml) (car xml))))))
721
722	)) ;; end module

Note: See TracBrowser for help on using the repository browser.

Download in other formats: