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.