Changeset 25905 in project for release/4/dbus/trunk/dbus.scm
- Timestamp:
- 02/14/12 21:11:09 (9 years ago)
- File:
-
- 1 edited
-
release/4/dbus/trunk/dbus.scm (modified) (10 diffs)
Legend:
- Unmodified
- Added
- Removed
-
release/4/dbus/trunk/dbus.scm
r25884 r25905 2 2 3 3 (module dbus (make-context 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 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 25 (import scheme chicken extras 26 26 (except foreign foreign-declare) … … 29 29 miscmacros) 30 30 (use srfi-18) 31 32 31 33 32 #> … … 49 48 (signature unsupported-type-signature)) 50 49 (define-record-printer (unsupported-type d out) 51 (fprintf out "#<unsupported-type ~ a>" (unsupported-type-signature d)))50 (fprintf out "#<unsupported-type ~s>" (unsupported-type-signature d))) 52 51 53 52 ;; Scheme is a dynamically typed language, so fundamentally we don't 54 53 ;; have a use for the "variant" concept; but since dbus has a variant type, 55 54 ;; we need a way of representing one when preparing a message for marshalling. 56 ;; So, it might as well be symmetric, putting any variant returned from57 ;; a dbus call into this type as well.58 55 (define-record-type variant 59 56 (make-variant data) … … 66 63 ;; By default this feature is turned off, in the interest of having a 67 64 ;; representation that is the same as you will need to build when 68 ;; you want to send (marshall) a dbus message. 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. 69 68 (define auto-unbox-variants (make-parameter #f)) 70 69 … … 121 120 (define type-signature-string (foreign-value DBUS_TYPE_SIGNATURE_AS_STRING int)) 122 121 (define type-array (foreign-value DBUS_TYPE_ARRAY int)) 123 (define type-array-string (foreign-value DBUS_TYPE_ARRAY_AS_STRING int))124 122 (define type-dict (foreign-value DBUS_TYPE_DICT_ENTRY int)) 125 123 (define type-variant (foreign-value DBUS_TYPE_VARIANT int)) … … 192 190 193 191 (define (any->string arg) 194 (if (string? arg) 195 arg 196 (if (eq? (void) arg) 197 "" 198 (format "~a" arg) 199 ))) 192 (if (string? arg) 193 arg 194 (if (eq? (void) arg) 195 "" 196 (format "~a" arg)))) 200 197 201 198 (define (symbol?->string arg) … … 341 338 "C_return (dbus_message_iter_append_basic(iter, DBUS_TYPE_UINT64, &v));")) 342 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 343 387 ;; TODO: iter-append-basic-T for each possible type: 344 388 ;; especially variant, array and struct might still be possible … … 352 396 [(flonum? val) (iter-append-basic-double iter val)] 353 397 [(boolean? val) (iter-append-basic-bool iter val)] 398 [(variant? val) (iter-append-basic-variant iter val)] 354 399 [(pair? val) 355 400 (let ([type (car val)]) … … 380 425 (let ( [type ((foreign-lambda int "dbus_message_iter_get_arg_type" 381 426 message-iter-ptr) iter)] ) 427 ; (printf "iter-cond type ~s~%" type) 382 428 (cond 383 429 [(memq type `(,type-string ,type-invalid-string … … 421 467 C_return (ret);") iter)] 422 468 [(eq? type type-array) 423 (iter->vector (make-sub-iter iter))] 469 (let ([v (iter->vector (make-sub-iter iter))]) 470 (when (and (vector? v) (eq? 1 (vector-length v)) (unsupported-type? (vector-ref v 0))) 471 (set! v (make-vector 0))) 472 v)] 424 473 [(eq? type type-dict) 425 474 (iter->pair (make-sub-iter iter))]
Note: See TracChangeset
for help on using the changeset viewer.
