Changeset 25884 in project
- Timestamp:
- 02/10/12 00:20:55 (9 years ago)
- Location:
- release/4/dbus/trunk
- Files:
-
- 13 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/dbus/trunk/dbus.scm
r25883 r25884 1 1 ;;;; dbus.scm 2 2 3 (module dbus ( dbus:make-context4 dbus:send5 dbus:call6 dbus:make-method-proxy7 dbus:register-signal-handler8 dbus:register-method9 dbus:enable-polling-thread!10 dbus:poll-for-message11 d bus:discover-services12 d bus:discover-api-xml13 dbus :dbus-service14 dbus:session-bus15 dbus:system-bus16 dbus:starter-bus17 dbus:known-bus-count18 dbus:register-path3 (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 19 unsupported-type? 20 20 unsupported-type-signature … … 70 70 71 71 ; Would want to do this: 72 ; (define-foreign-enum ( dbus:bus (enum "DBusBusType"))73 ; ( dbus:session-bus DBUS_BUS_SESSION)74 ; ( dbus:system-bus DBUS_BUS_SYSTEM)75 ; ( dbus:starter-bus DBUS_BUS_STARTER) )72 ; (define-foreign-enum (bus (enum "DBusBusType")) 73 ; (session-bus DBUS_BUS_SESSION) 74 ; (system-bus DBUS_BUS_SYSTEM) 75 ; (starter-bus DBUS_BUS_STARTER) ) 76 76 ; but because that enum is typedef'd, chicken has a problem with it. 77 77 78 (define-foreign-type dbus:bus int) ; really "DBusBusType"79 (define dbus:session-bus (foreign-value DBUS_BUS_SESSION int))80 (define dbus:system-bus (foreign-value DBUS_BUS_SYSTEM int))81 (define dbus:starter-bus (foreign-value DBUS_BUS_STARTER int))82 (define dbus :dbus-service (foreign-value DBUS_SERVICE_DBUS c-string))83 (define dbus:known-bus-count (+ 1 (max dbus:session-bus dbus:system-bus dbus:starter-bus)))84 85 (define-foreign-type dbus:handler-result int) ; really "DBusHandlerResult"86 (define dbus:result-handled (foreign-value DBUS_HANDLER_RESULT_HANDLED int))87 (define dbus:result-not-yet-handled (foreign-value DBUS_HANDLER_RESULT_NOT_YET_HANDLED int))88 (define dbus:result-need-memory (foreign-value DBUS_HANDLER_RESULT_NEED_MEMORY int))89 90 (define dbus:name-flag-allow-replacement (foreign-value DBUS_NAME_FLAG_ALLOW_REPLACEMENT int))91 (define dbus:name-flag-replace-existing (foreign-value DBUS_NAME_FLAG_REPLACE_EXISTING int))92 (define dbus:name-flag-do-not-queue (foreign-value DBUS_NAME_FLAG_DO_NOT_QUEUE int))78 (define-foreign-type bus int) ; really "DBusBusType" 79 (define session-bus (foreign-value DBUS_BUS_SESSION int)) 80 (define system-bus (foreign-value DBUS_BUS_SYSTEM int)) 81 (define starter-bus (foreign-value DBUS_BUS_STARTER int)) 82 (define dbus-service (foreign-value DBUS_SERVICE_DBUS c-string)) 83 (define known-bus-count (+ 1 (max session-bus system-bus starter-bus))) 84 85 (define-foreign-type handler-result int) ; really "DBusHandlerResult" 86 (define result-handled (foreign-value DBUS_HANDLER_RESULT_HANDLED int)) 87 (define result-not-yet-handled (foreign-value DBUS_HANDLER_RESULT_NOT_YET_HANDLED int)) 88 (define result-need-memory (foreign-value DBUS_HANDLER_RESULT_NEED_MEMORY int)) 89 90 (define name-flag-allow-replacement (foreign-value DBUS_NAME_FLAG_ALLOW_REPLACEMENT int)) 91 (define name-flag-replace-existing (foreign-value DBUS_NAME_FLAG_REPLACE_EXISTING int)) 92 (define name-flag-do-not-queue (foreign-value DBUS_NAME_FLAG_DO_NOT_QUEUE int)) 93 93 94 94 ;; DBus simple data types 95 (define dbus:type-invalid (foreign-value DBUS_TYPE_INVALID int))96 (define dbus:type-invalid-string (foreign-value DBUS_TYPE_INVALID_AS_STRING int))97 (define dbus:type-byte (foreign-value DBUS_TYPE_BYTE int))98 (define dbus:type-byte-string (foreign-value DBUS_TYPE_BYTE_AS_STRING int))99 (define dbus:type-boolean (foreign-value DBUS_TYPE_BOOLEAN int))100 (define dbus:type-boolean-string (foreign-value DBUS_TYPE_BOOLEAN_AS_STRING int))101 (define dbus:type-int16 (foreign-value DBUS_TYPE_INT16 int))102 (define dbus:type-int16-string (foreign-value DBUS_TYPE_INT16_AS_STRING int))103 (define dbus:type-uint16 (foreign-value DBUS_TYPE_UINT16 int))104 (define dbus:type-uint16-string (foreign-value DBUS_TYPE_UINT16_AS_STRING int))105 (define dbus:type-fixnum (foreign-value DBUS_TYPE_INT32 int))106 (define dbus:type-int32 (foreign-value DBUS_TYPE_INT32 int))107 (define dbus:type-int32-string (foreign-value DBUS_TYPE_INT32_AS_STRING int))108 (define dbus:type-uint32 (foreign-value DBUS_TYPE_UINT32 int))109 (define dbus:type-uint32-string (foreign-value DBUS_TYPE_UINT32_AS_STRING int))110 (define dbus:type-int64 (foreign-value DBUS_TYPE_INT64 int))111 (define dbus:type-int64-string (foreign-value DBUS_TYPE_INT64_AS_STRING int))112 (define dbus:type-uint64 (foreign-value DBUS_TYPE_UINT64 int))113 (define dbus:type-uint64-string (foreign-value DBUS_TYPE_UINT64_AS_STRING int))114 (define dbus:type-double (foreign-value DBUS_TYPE_DOUBLE int))115 (define dbus:type-flonum (foreign-value DBUS_TYPE_DOUBLE int))116 (define dbus:type-double-string (foreign-value DBUS_TYPE_DOUBLE_AS_STRING int))117 (define dbus:type-string (foreign-value DBUS_TYPE_STRING int))118 (define dbus:type-string-string (foreign-value DBUS_TYPE_STRING_AS_STRING int))119 (define dbus:type-object-path (foreign-value DBUS_TYPE_OBJECT_PATH int))120 (define dbus:type-signature (foreign-value DBUS_TYPE_SIGNATURE int))121 (define dbus:type-signature-string (foreign-value DBUS_TYPE_SIGNATURE_AS_STRING int))122 (define dbus:type-array (foreign-value DBUS_TYPE_ARRAY int))123 (define dbus:type-array-string (foreign-value DBUS_TYPE_ARRAY_AS_STRING int))124 (define dbus:type-dict (foreign-value DBUS_TYPE_DICT_ENTRY int))125 (define dbus:type-variant (foreign-value DBUS_TYPE_VARIANT int))126 127 (define dbus:make-context)128 (define dbus:send)129 (define dbus:make-method-proxy)130 (define dbus:call)131 (define dbus:flush)132 (define dbus:poll-for-message)133 (define dbus:register-signal-handler)134 (define dbus:register-method)135 (define dbus:register-path)136 (define dbus:enable-polling-thread!)137 138 (define dbus:add-match)139 (define dbus:request-name)95 (define type-invalid (foreign-value DBUS_TYPE_INVALID int)) 96 (define type-invalid-string (foreign-value DBUS_TYPE_INVALID_AS_STRING int)) 97 (define type-byte (foreign-value DBUS_TYPE_BYTE int)) 98 (define type-byte-string (foreign-value DBUS_TYPE_BYTE_AS_STRING int)) 99 (define type-boolean (foreign-value DBUS_TYPE_BOOLEAN int)) 100 (define type-boolean-string (foreign-value DBUS_TYPE_BOOLEAN_AS_STRING int)) 101 (define type-int16 (foreign-value DBUS_TYPE_INT16 int)) 102 (define type-int16-string (foreign-value DBUS_TYPE_INT16_AS_STRING int)) 103 (define type-uint16 (foreign-value DBUS_TYPE_UINT16 int)) 104 (define type-uint16-string (foreign-value DBUS_TYPE_UINT16_AS_STRING int)) 105 (define type-fixnum (foreign-value DBUS_TYPE_INT32 int)) 106 (define type-int32 (foreign-value DBUS_TYPE_INT32 int)) 107 (define type-int32-string (foreign-value DBUS_TYPE_INT32_AS_STRING int)) 108 (define type-uint32 (foreign-value DBUS_TYPE_UINT32 int)) 109 (define type-uint32-string (foreign-value DBUS_TYPE_UINT32_AS_STRING int)) 110 (define type-int64 (foreign-value DBUS_TYPE_INT64 int)) 111 (define type-int64-string (foreign-value DBUS_TYPE_INT64_AS_STRING int)) 112 (define type-uint64 (foreign-value DBUS_TYPE_UINT64 int)) 113 (define type-uint64-string (foreign-value DBUS_TYPE_UINT64_AS_STRING int)) 114 (define type-double (foreign-value DBUS_TYPE_DOUBLE int)) 115 (define type-flonum (foreign-value DBUS_TYPE_DOUBLE int)) 116 (define type-double-string (foreign-value DBUS_TYPE_DOUBLE_AS_STRING int)) 117 (define type-string (foreign-value DBUS_TYPE_STRING int)) 118 (define type-string-string (foreign-value DBUS_TYPE_STRING_AS_STRING int)) 119 (define type-object-path (foreign-value DBUS_TYPE_OBJECT_PATH int)) 120 (define type-signature (foreign-value DBUS_TYPE_SIGNATURE int)) 121 (define type-signature-string (foreign-value DBUS_TYPE_SIGNATURE_AS_STRING int)) 122 (define type-array (foreign-value DBUS_TYPE_ARRAY int)) 123 (define type-array-string (foreign-value DBUS_TYPE_ARRAY_AS_STRING int)) 124 (define type-dict (foreign-value DBUS_TYPE_DICT_ENTRY int)) 125 (define type-variant (foreign-value DBUS_TYPE_VARIANT int)) 126 127 (define make-context) 128 (define send) 129 (define make-method-proxy) 130 (define call) 131 (define flush) 132 (define poll-for-message) 133 (define register-signal-handler) 134 (define register-method) 135 (define register-path) 136 (define enable-polling-thread!) 137 138 (define add-match) 139 (define request-name) 140 140 141 141 … … 149 149 (define-foreign-type vtable-ptr c-pointer) ;; DBusObjectPathVTable* 150 150 151 (define (d bus:discover-services #!key (bus dbus:session-bus))152 (let* ([ctxt ( dbus:make-context151 (define (discover-services #!key (bus session-bus)) 152 (let* ([ctxt (make-context 153 153 bus: bus 154 154 service: 'org.freedesktop.DBus 155 155 interface: 'org.freedesktop.DBus 156 156 path: '/org/freedesktop/DBus)] 157 [services ( dbus:call ctxt "ListNames")])157 [services (call ctxt "ListNames")]) 158 158 (and (pair? services) (vector? (car services)) (vector->list (car services))))) 159 159 160 (define d bus:discover-api-xml)161 162 (define-external (C_msg_cb ( dbus:bus bus) (message-ptr msg)) bool160 (define discover-api-xml) 161 162 (define-external (C_msg_cb (bus bus) (message-ptr msg)) bool 163 163 (let* ([cb (find-callback bus msg)][found (procedure? cb)]) 164 164 ; (printf "got a message: ~s on bus ~a and found callback ~s~%" msg bus cb) … … 168 168 )) 169 169 170 (let ( [connections '()] ;; an alist mapping dbus:bus to DBusConnection ptrs170 (let ( [connections '()] ;; an alist mapping bus to DBusConnection ptrs 171 171 [error (foreign-value "&err" c-pointer)] 172 172 ;; indices in a "context" vector … … 178 178 [context-count 0] 179 179 [default-polling-interval 0.01] 180 [polling-interval (make-vector dbus:known-bus-count 0.01)]181 [polling-enabled (make-vector dbus:known-bus-count #t)]182 [polling-threads (make-vector dbus:known-bus-count #f)]180 [polling-interval (make-vector known-bus-count 0.01)] 181 [polling-enabled (make-vector known-bus-count #t)] 182 [polling-threads (make-vector known-bus-count #f)] 183 183 ;; will become an assoc tree: 184 184 ;; bus … … 188 188 ;; method 189 189 ;; callback-fn 190 [callbacks-table `((, dbus:system-bus . #f) (,dbus:session-bus . #f))]190 [callbacks-table `((,system-bus . #f) (,session-bus . #f))] 191 191 [iterm (gensym 'terminiter)] ) 192 192 … … 270 270 (set! conn (cdr conn)) 271 271 (begin 272 (set! conn ((foreign-lambda connection-ptr "dbus_bus_get" dbus:bus error-ptr)272 (set! conn ((foreign-lambda connection-ptr "dbus_bus_get" bus error-ptr) 273 273 bus-type error) ) 274 274 (when conn … … 345 345 346 346 ;; val would usually be a single value, but 347 ;; could be a pair of the form ( dbus:type-x . value)347 ;; could be a pair of the form (type-x . value) 348 348 ;; in which case we will attempt to convert the value to that type for sending. 349 349 (define (iter-append-basic iter val) … … 359 359 ;; do not match parameter-list (a207 a206) 360 360 ;; so I guess it has to _be_ a byte before the call 361 ; [(eq? type dbus:type-byte)361 ; [(eq? type type-byte) 362 362 ; (iter-append-basic-byte (cdr val))] 363 ; [(eq? type dbus:type-int16)363 ; [(eq? type type-int16) 364 364 ; (iter-append-basic-int16 (cdr val))] 365 ; [(eq? type dbus:type-uint32)365 ; [(eq? type type-uint32) 366 366 ; (iter-append-basic-uint32 (cdr val))] 367 ; [(eq? type dbus:type-uint16)367 ; [(eq? type type-uint16) 368 368 ; (iter-append-basic-uint16 (cdr val))] 369 ; [(eq? type dbus:type-int64)369 ; [(eq? type type-int64) 370 370 ; (iter-append-basic-int64 (cdr val))] 371 ; [(eq? type dbus:type-uint64)371 ; [(eq? type type-uint64) 372 372 ; (iter-append-basic-uint64 (cdr val))] 373 373 ;; other custom requests will be handled as usual, above … … 381 381 message-iter-ptr) iter)] ) 382 382 (cond 383 [(memq type `(, dbus:type-string ,dbus:type-invalid-string384 , dbus:type-string-string ,dbus:type-object-path385 , dbus:type-signature-string383 [(memq type `(,type-string ,type-invalid-string 384 ,type-string-string ,type-object-path 385 ,type-signature-string 386 386 ;; TODO maybe the following types ought to be converted? 387 , dbus:type-byte-string ,dbus:type-boolean-string388 , dbus:type-int16-string ,dbus:type-uint16-string389 , dbus:type-int32-string ,dbus:type-uint32-string390 , dbus:type-int64-string ,dbus:type-uint64-string391 , dbus:type-double-string ))387 ,type-byte-string ,type-boolean-string 388 ,type-int16-string ,type-uint16-string 389 ,type-int32-string ,type-uint32-string 390 ,type-int64-string ,type-uint64-string 391 ,type-double-string )) 392 392 ((foreign-lambda* c-string ((message-iter-ptr iter)) 393 393 "char* ret; 394 394 dbus_message_iter_get_basic(iter, &ret); 395 395 C_return (ret);") iter)] 396 [(eq? type dbus:type-boolean)396 [(eq? type type-boolean) 397 397 ((foreign-lambda* bool ((message-iter-ptr iter)) 398 398 "bool ret; 399 399 dbus_message_iter_get_basic(iter, &ret); 400 400 return (ret);") iter)] 401 [(memq type `(, dbus:type-int32 ,dbus:type-byte402 , dbus:type-int16 ))401 [(memq type `(,type-int32 ,type-byte 402 ,type-int16 )) 403 403 ((foreign-lambda* int ((message-iter-ptr iter)) 404 404 "int ret; 405 405 dbus_message_iter_get_basic(iter, &ret); 406 406 C_return (ret);") iter)] 407 [(memq type `(, dbus:type-uint32 ,dbus:type-uint16))407 [(memq type `(,type-uint32 ,type-uint16)) 408 408 ((foreign-lambda* unsigned-int ((message-iter-ptr iter)) 409 409 "unsigned int ret; 410 410 dbus_message_iter_get_basic(iter, &ret); 411 411 C_return (ret);") iter)] 412 [(memq type `(, dbus:type-flonum ,dbus:type-uint64))412 [(memq type `(,type-flonum ,type-uint64)) 413 413 ((foreign-lambda* double ((message-iter-ptr iter)) 414 414 "double ret; 415 415 dbus_message_iter_get_basic(iter, &ret); 416 416 C_return (ret);") iter)] 417 [(eq? type dbus:type-int64)417 [(eq? type type-int64) 418 418 ((foreign-lambda* integer64 ((message-iter-ptr iter)) 419 419 "int64_t ret; 420 420 dbus_message_iter_get_basic(iter, &ret); 421 421 C_return (ret);") iter)] 422 [(eq? type dbus:type-array)422 [(eq? type type-array) 423 423 (iter->vector (make-sub-iter iter))] 424 [(eq? type dbus:type-dict)424 [(eq? type type-dict) 425 425 (iter->pair (make-sub-iter iter))] 426 [(eq? type dbus:type-variant)426 [(eq? type type-variant) 427 427 (if (auto-unbox-variants) 428 428 ((make-sub-iter iter)) 429 429 (make-variant ((make-sub-iter iter))))] 430 430 ;; unsupported so far (not understood well enough): 431 ;; dbus:type-object-path and dbus:type-signature432 ;; dbus:type-invalid is returned as #f (could be (void) but that431 ;; type-object-path and type-signature 432 ;; type-invalid is returned as #f (could be (void) but that 433 433 ;; would be the termination condition for the iterator) 434 434 [else (make-unsupported-type (integer->char type))] ))) … … 519 519 (tassq callbacks-table bus path iface mber) )))) 520 520 521 (set! dbus:make-context (lambda (#!key (bus dbus:session-bus) service interface (path "/"))521 (set! make-context (lambda (#!key (bus session-bus) service interface (path "/")) 522 522 (vector (next-context-ID) bus (string?->symbol service) 523 523 (string?->symbol path) (string?->symbol interface)) )) … … 526 526 (foreign-lambda int "dbus_connection_send" connection-ptr message-ptr uint-ptr)) 527 527 528 (set! dbus:send (lambda (context name . params)528 (set! send (lambda (context name . params) 529 529 (let* ( [service (symbol?->string (vector-ref context context-idx-service))] 530 530 [msg (make-signal … … 542 542 )))) 543 543 544 (set! dbus:call (lambda (context name . params)544 (set! call (lambda (context name . params) 545 545 (let* ( [service (symbol->string (vector-ref context context-idx-service))] 546 546 [msg (make-message service … … 569 569 reply-args))))) 570 570 571 (set! dbus:make-method-proxy (lambda (context name)571 (set! make-method-proxy (lambda (context name) 572 572 (let ( [service (symbol->string (vector-ref context context-idx-service))] 573 573 [conn (conn-or-abort (vector-ref context context-idx-bus))] ) … … 596 596 reply-args)))))) 597 597 598 (define-foreign-record-type ( dbus:vtable "struct DBusObjectPathVTable")599 (constructor: dbus:make-vtable-impl)600 (destructor: dbus:free-vtable)601 (c-pointer unregister_function dbus:vtable-unregister_function dbus:vtable-unregister_function-set!)602 (c-pointer message_function dbus:vtable-message_function dbus:vtable-message_function-set!)603 (c-pointer dbus_internal_pad1 dbus:vtable-dbus_internal_pad1)604 (c-pointer dbus_internal_pad2 dbus:vtable-dbus_internal_pad2)605 (c-pointer dbus_internal_pad3 dbus:vtable-dbus_internal_pad3)606 (c-pointer dbus_internal_pad4 dbus:vtable-dbus_internal_pad4))607 608 (define ( dbus:make-vtable cb unreg-cb)598 (define-foreign-record-type (vtable "struct DBusObjectPathVTable") 599 (constructor: make-vtable-impl) 600 (destructor: free-vtable) 601 (c-pointer unregister_function vtable-unregister_function vtable-unregister_function-set!) 602 (c-pointer message_function vtable-message_function vtable-message_function-set!) 603 (c-pointer dbus_internal_pad1 vtable-dbus_internal_pad1) 604 (c-pointer dbus_internal_pad2 vtable-dbus_internal_pad2) 605 (c-pointer dbus_internal_pad3 vtable-dbus_internal_pad3) 606 (c-pointer dbus_internal_pad4 vtable-dbus_internal_pad4)) 607 608 (define (make-vtable cb unreg-cb) 609 609 (let () 610 610 (define (fn conn msg user-data) … … 612 612 (let ([ret (cb conn msg user-data)]) 613 613 ;; TODO: return ret as the result 614 dbus:result-handled ))615 (let ([ret ( dbus:make-vtable-impl)])616 ( dbus:vtable-message_function-set! ret fn)617 ( dbus:vtable-unregister_function-set! ret unreg-cb)614 result-handled )) 615 (let ([ret (make-vtable-impl)]) 616 (vtable-message_function-set! ret fn) 617 (vtable-unregister_function-set! ret unreg-cb) 618 618 ret) )) 619 619 620 ; (set! dbus:add-match-self (lambda ()620 ; (set! add-match-self (lambda () 621 621 ; ((foreign-safe-lambda void "dbus_bus_add_match" connection-ptr c-string error-ptr) 622 622 ; (get-conn (vector-ref context context-idx-bus)) rule #f) )) 623 623 624 (set! dbus:read-write (lambda (conn timeout)624 (set! read-write (lambda (conn timeout) 625 625 (let () 626 626 ((foreign-safe-lambda bool "dbus_connection_read_write" connection-ptr int) 627 627 conn timeout)))) 628 628 629 (set! dbus:request-name (lambda (context)629 (set! request-name (lambda (context) 630 630 (let ([service-name (symbol?->string (vector-ref context context-idx-service))]) 631 631 (conn-or-abort (vector-ref context context-idx-bus)) … … 634 634 (get-conn (vector-ref context context-idx-bus)) 635 635 service-name 636 dbus:name-flag-replace-existing #f) ))))637 638 (set! dbus:add-match (lambda (context)636 name-flag-replace-existing #f) )))) 637 638 (set! add-match (lambda (context) 639 639 ;; TODO is it always type signal? We are using this for methods too. 640 640 (let ([rule (format "type='signal', interface='~s'" (vector-ref context context-idx-interface))]) … … 644 644 645 645 ;; return #t if it received a message, #f if not 646 (set! dbus:poll-for-message (lambda (#!key (bus dbus:session-bus) (timeout 0))646 (set! poll-for-message (lambda (#!key (bus session-bus) (timeout 0)) 647 647 (let ([conn (conn-or-abort bus)]) 648 648 ; (exists-or-abort conn (format "no connection to bus ~s~%" (vector-ref context context-idx-bus))) 649 649 ((foreign-safe-lambda* bool 650 ((connection-ptr conn) ( dbus:bus bus) (int timeout))650 ((connection-ptr conn) (bus bus) (int timeout)) 651 651 "DBusMessage* msg = NULL; 652 652 dbus_connection_read_write(conn, timeout); … … 664 664 665 665 ;; TODO: one polling thread is necessary for each connection 666 (define ( dbus:start-polling! bus interval)666 (define (start-polling! bus interval) 667 667 (vector-set! polling-interval bus interval) 668 668 ; (pretty-print callbacks-table) … … 672 672 (let loop () 673 673 ; (printf "polling~%") 674 ( dbus:poll-for-message bus: bus timeout: 0)674 (poll-for-message bus: bus timeout: 0) 675 675 (thread-sleep! (vector-ref polling-interval bus)) 676 676 (when (vector-ref polling-enabled bus) (loop))))))))) 677 677 678 (set! dbus:enable-polling-thread! (lambda (#!key (bus dbus:session-bus) (enable #t) (interval default-polling-interval))678 (set! enable-polling-thread! (lambda (#!key (bus session-bus) (enable #t) (interval default-polling-interval)) 679 679 (vector-set! polling-enabled bus enable) 680 680 (if enable 681 ( dbus:start-polling! bus interval)681 (start-polling! bus interval) 682 682 (let ([th (vector-ref polling-threads bus)]) 683 683 (when th (thread-join! th)))))) … … 710 710 711 711 ;; msg-cb: the handler implementation. Its return value is ignored. 712 (set! dbus:register-signal-handler (lambda (context name msg-cb)713 ( dbus:request-name context)714 ( dbus:add-match context)712 (set! register-signal-handler (lambda (context name msg-cb) 713 (request-name context) 714 (add-match context) 715 715 (tasset! callbacks-table 716 716 (handler-wrapper (conn-or-abort (vector-ref context context-idx-bus)) msg-cb) … … 719 719 (vector-ref context context-idx-interface) 720 720 (string?->symbol name)) 721 ( dbus:start-polling! (vector-ref context context-idx-bus) default-polling-interval)721 (start-polling! (vector-ref context context-idx-bus) default-polling-interval) 722 722 )) 723 723 724 724 ;; msg-cb: the method implementation. Its return value is sent back as the response. 725 (set! dbus:register-method (lambda (context name msg-cb)726 ( dbus:request-name context)727 ; ( dbus:add-match context) doesn't seem to be necessary725 (set! register-method (lambda (context name msg-cb) 726 (request-name context) 727 ; (add-match context) doesn't seem to be necessary 728 728 (tasset! callbacks-table 729 729 (method-wrapper (conn-or-abort (vector-ref context context-idx-bus)) msg-cb) … … 733 733 (vector-ref context context-idx-interface) 734 734 (string?->symbol name)) 735 ( dbus:start-polling! (vector-ref context context-idx-bus) default-polling-interval)735 (start-polling! (vector-ref context context-idx-bus) default-polling-interval) 736 736 )) 737 737 … … 740 740 ; const DBusObjectPathVTable *vtable, 741 741 ; void *user_data); 742 (set! dbus:register-path (lambda (bus path fn unreg-fn)742 (set! register-path (lambda (bus path fn unreg-fn) 743 743 ; (let ([unreg-fn (lambda (parm . rest) #f)]) 744 744 ((foreign-safe-lambda bool "dbus_connection_register_object_path" … … 746 746 (conn-or-abort bus) 747 747 (symbol?->string path) 748 ( dbus:make-vtable fn unreg-fn) #f)))749 750 (set! d bus:discover-api-xml (lambda (ctxt)748 (make-vtable fn unreg-fn) #f))) 749 750 (set! discover-api-xml (lambda (ctxt) 751 751 (let ([ctxt (list->vector (vector->list ctxt))]) ;; todo: efficiency? 752 752 (vector-set! ctxt context-idx-interface 'org.freedesktop.DBus.Introspectable) 753 (let ([xml ( dbus:call ctxt "Introspect")])753 (let ([xml (call ctxt "Introspect")]) 754 754 (and (pair? xml) (car xml)))))) 755 755 -
release/4/dbus/trunk/examples/introspect-avahi.scm
r19799 r25884 1 (use dbus)1 (use (prefix dbus dbus:)) 2 2 3 3 (define ctxt (dbus:make-context -
release/4/dbus/trunk/examples/introspect-connman.scm
r25883 r25884 1 (use dbus)1 (use (prefix dbus dbus:)) 2 2 3 3 (define ctxt (dbus:make-context … … 27 27 28 28 (printf "~%==== Manager Properties:~%") 29 ( auto-unbox-variants #t)29 (dbus:auto-unbox-variants #t) 30 30 (let ([mgr-props (dbus:call mgr-ctxt "GetProperties")]) 31 31 (pretty-print mgr-props) -
release/4/dbus/trunk/examples/introspect-hal.scm
r19799 r25884 1 (use dbus)1 (use (prefix dbus dbus:)) 2 2 3 3 (define ctxt (dbus:make-context -
release/4/dbus/trunk/examples/introspect-phonekit.scm
r19799 r25884 1 (use dbus)1 (use (prefix dbus dbus:)) 2 2 3 3 (define ctxt (dbus:make-context -
release/4/dbus/trunk/examples/introspect-services.scm
r19799 r25884 1 (use dbus)1 (use (prefix dbus dbus:)) 2 2 3 3 ;; the actual dbus call to get known service names: -
release/4/dbus/trunk/examples/listen-example.scm
r19799 r25884 1 (use dbus)1 (use (prefix dbus dbus:)) 2 2 3 3 (define (query . params) -
release/4/dbus/trunk/examples/paranoid-android.scm
r19799 r25884 5 5 ;; but the remote-control API can still be the same 6 6 7 (use dbus)7 (use (prefix dbus dbus:)) 8 8 9 9 (define (turn-right) (printf "rolls eyes and turns to the right~%")) -
release/4/dbus/trunk/examples/receive-car-turn.scm
r19799 r25884 1 (use dbus)1 (use (prefix dbus dbus:)) 2 2 3 3 (define (turn-right) (printf "car is turning to the right~%")) -
release/4/dbus/trunk/examples/receive-signal.scm
r19799 r25884 1 (use dbus)1 (use (prefix dbus dbus:)) 2 2 3 3 (define (signal . parms) (printf "got signal ~s~%" parms)) -
release/4/dbus/trunk/examples/send-car-turn.scm
r19799 r25884 1 (use dbus)1 (use (prefix dbus dbus:)) 2 2 3 3 (define rc-car-context (dbus:make-context -
release/4/dbus/trunk/examples/send-example-query.scm
r19799 r25884 1 (use dbus)1 (use (prefix dbus dbus:)) 2 2 3 3 (define ctxt (dbus:make-context -
release/4/dbus/trunk/examples/send-signal.scm
r19799 r25884 1 (use dbus)1 (use (prefix dbus dbus:)) 2 2 3 3 (define ctxt (dbus:make-context interface: 'language.english path: '/humanity))
Note: See TracChangeset
for help on using the changeset viewer.