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

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

initialize int return values to avoid garbage when reading smaller types

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