| #! /bin/sh
|
| # -*- mode: scheme; coding: utf-8 -*-
|
| exec guile -e main -s "$0" "$@"
|
| !#
|
|
|
| (eval-when (expand load eval)
|
| (use-modules (oop goops))
|
|
|
| (default-duplicate-binding-handler
|
| '(merge-generics replace warn-override-core warn last))
|
|
|
| (use-modules (g-golf))
|
|
|
| (g-irepository-require "Gio")
|
| (for-each (lambda (name)
|
| (gi-import-by-name "Gio" name))
|
| '("DBusConnection"
|
| "DBusInterfaceInfo"
|
| "DBusMethodInvocation"
|
| "bus_own_name"
|
| "bus_unown_name")))
|
|
|
|
|
| (define-class <server> ()
|
| (conn #:init-keyword #:conn))
|
|
|
| (define (on-method-call conn
|
| str-sender
|
| str-object
|
| str-interface
|
| str-method
|
| vnt-parameters
|
| invocation)
|
| (dimfi (format #f "~20,,,' @A" " on-method-call"))
|
| (if (equal? str-method "MyMethod1")
|
| (let ((vnt-params (gd-bus-method-invocation-get-parameters invocation)))
|
| (dimfi (format #f "~20,,,' @A" " params")
|
| vnt-params
|
| (g-variant-type-dup-string (g-variant-get-type vnt-params)))
|
| (if (eqv? (g-variant-n-children vnt-params) 1)
|
| (let ((str-arg
|
| (g-variant-get-string
|
| (g-variant-get-child-value vnt-params 0))))
|
| (dimfi (format #f "~20,,,' @A" " on-method-call/1"))
|
| (let ((i-response
|
| (cond
|
| ((equal? str-arg "Lucky number") 13)
|
| ((equal? str-arg "Age") 50)
|
| (else -1))))
|
| (let* ((vnt-response (g-variant-new-int64 i-response))
|
| (vnt-tuple
|
| (g-variant-new-tuple (list vnt-response))))
|
| (dimfi (format #f "~20,,,' @A" " on-method-call/2")
|
| (g-variant-type-dup-string (g-variant-get-type vnt-tuple)))
|
| ;; (g-variant-ref vnt-response)
|
| ;; (g-variant-ref vnt-tuple)
|
| (gd-bus-method-invocation-return-value invocation
|
| vnt-tuple))))
|
| (display "Invalid number of arguments to MyMethod1.\n")))
|
| (display (string-append "Unknown method " str-method ".\n"))))
|
|
|
| (define (on-bus-acquired server conn str-name)
|
| (dimfi (format #f "~20,,,' @A" " on-bus-acquired"))
|
| (slot-set! server 'conn conn)
|
| (let* ((x-arg1
|
| (make-c-struct (list int64 '* '* '*)
|
| (list 1
|
| (string->pointer "str-choice")
|
| (string->pointer "s")
|
| %null-pointer)))
|
| (x-arguments (scm->gi-pointers (list x-arg1)))
|
| (x-return-value
|
| (make-c-struct
|
| (list int64 '* '* '*)
|
| (list 1
|
| (string->pointer "i-result")
|
| (string->pointer "x")
|
| %null-pointer)))
|
| (x-return-values
|
| (scm->gi-pointers (list x-return-value)))
|
| (x-method1
|
| (make-c-struct (list int64 '* '* '* '*)
|
| (list 1
|
| (string->pointer "MyMethod1")
|
| x-arguments
|
| x-return-values
|
| %null-pointer)))
|
| (x-methods (scm->gi-pointers (list x-method1)))
|
| (x-interface-info
|
| (make-c-struct (list int64 '* '* '* '* '*)
|
| (list 1
|
| (string->pointer "fi.tohoyn.DBusServer1")
|
| x-methods
|
| %null-pointer
|
| %null-pointer
|
| %null-pointer)))
|
| (i-reg-id
|
| (gd-bus-connection-register-object-with-closures2
|
| conn
|
| "/fi/tohoyn/DBusServer1"
|
| x-interface-info
|
| on-method-call
|
| #f
|
| #f)))
|
| (if (<= i-reg-id 0)
|
| (raise 'on-bus-acquired:object-reg-failed))))
|
|
|
|
|
| (define (on-name-acquired server conn str-name)
|
| (dimfi (format #f "~20,,,' @A" " on-name-acquired")))
|
|
|
|
|
| (define (on-name-lost server conn str-name)
|
| (dimfi (format #f "~20,,,' @A" " on-name-lost"))
|
| (exit 1))
|
|
|
|
|
| (define (main args)
|
| (let* ((loop (g-main-loop-new))
|
| (server (make <server> #:conn #f))
|
| (i-id
|
| (g-bus-own-name-with-closures
|
| 'session
|
| "fi.tohoyn.DBusServer1"
|
| '(none)
|
| (lambda (conn str-name)
|
| (on-bus-acquired server conn str-name))
|
| (lambda (conn str-name)
|
| (on-name-acquired server conn str-name))
|
| (lambda (conn str-name)
|
| (on-name-lost server conn str-name)))))
|
| (g-main-loop-run loop)
|
| (g-bus-unown-name i-id)))
|