| #! /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"
|
| "DBusNodeInfo"
|
| "bus_own_name"
|
| "bus_unown_name")))
|
|
|
|
|
| (define %dbus-node
|
| "<node>
|
| <interface name='org.gnu.test.DBus'>
|
| <method name='Method1'>
|
| <arg name='arg1' type='s' direction='in'/>
|
| <arg name='res1' type='x' direction='out'/>
|
| </method>
|
| <method name='Method2'>
|
| <arg name='arg1' type='x' direction='in'/>
|
| <arg name='res1' type='s' direction='out'/>
|
| <arg name='res2' type='x' direction='out'/>
|
| </method>
|
| <signal name='Signal1'>
|
| <arg name='param' type='x'/>
|
| </signal>
|
| </interface>
|
| </node>")
|
|
|
| (define (dbus-node->interface-info dbus-node)
|
| (g-dbus-node-info-lookup-interface (g-dbus-node-info-new-for-xml dbus-node)
|
| "org.gnu.test.DBus"))
|
|
|
| (define (on-method-call connection
|
| sender
|
| object-path
|
| interface-name
|
| method-name
|
| parameters
|
| invocation)
|
| (when (%debug)
|
| (dimfi 'on-method-call)
|
| (dimfi (format #f "~20,,,' @A" "connection") connection)
|
| (dimfi (format #f "~20,,,' @A" "sender") sender)
|
| (dimfi (format #f "~20,,,' @A" "object-path") object-path)
|
| (dimfi (format #f "~20,,,' @A" "interface-name") interface-name)
|
| (dimfi (format #f "~20,,,' @A" "method-name") method-name)
|
| (dimfi (format #f "~20,,,' @A" "parameters") parameters)
|
| (dimfi (format #f "~20,,,' @A" "invocation") invocation))
|
| (case (string->symbol method-name)
|
| ((Method1)
|
| (let* ((params (get-parameters invocation))
|
| (child (g-variant-get-child-value params 0))
|
| (arg1 (g-variant-get-string child))
|
| (res1 (g-variant-new-int64
|
| (cond
|
| ((string=? arg1 "Lucky number") 13)
|
| ((string=? arg1 "Age") 50)
|
| (else -1))))
|
| (tuple (g-variant-new-tuple `(,res1))))
|
| (g-object-ref invocation)
|
| (return-value invocation tuple)))
|
| ((Method2)
|
| (let* ((params (get-parameters invocation))
|
| (child (g-variant-get-child-value params 0))
|
| (arg1 (g-variant-get-int64 child))
|
| (res-1 (g-variant-new-string "Hello"))
|
| (res-2 (g-variant-new-int64 42))
|
| (tuple (g-variant-new-tuple `(,res-1 ,res-2))))
|
| (g-object-ref invocation)
|
| (return-value invocation tuple)
|
| (emit-signal connection
|
| #f
|
| "/org/gnu/test/DBus"
|
| "org.gnu.test.DBus"
|
| "Signal1"
|
| (g-variant-new-tuple `(,(g-variant-new-int64 -1))))))
|
| (else
|
| (error "Unknown method " method-name))))
|
|
|
| (define (on-bus-acquired connection name)
|
| (unless (> (register-object-with-closures2 connection
|
| "/org/gnu/test/DBus"
|
| (dbus-node->interface-info %dbus-node)
|
| on-method-call
|
| #f
|
| #f)
|
| 0)
|
| (error 'on-bus-acquired:object-reg-failed)))
|
|
|
|
|
| (define (on-name-acquired connection name)
|
| (when (%debug)
|
| (dimfi 'on-name-acquired)))
|
|
|
|
|
| (define (on-name-lost connection name)
|
| (when (%debug)
|
| (dimfi 'on-name-lost))
|
| (exit 1))
|
|
|
|
|
| (define (main args)
|
| (letrec ((debug? (or (member "-d" args)
|
| (member "--debug" args)))
|
| (animate (lambda ()
|
| (let ((loop (g-main-loop-new)))
|
| (g-bus-own-name-with-closures 'session
|
| "org.gnu.test.DBus"
|
| '(none)
|
| on-bus-acquired
|
| on-name-acquired
|
| on-name-lost)
|
| (g-main-loop-run loop)))))
|
| (if debug?
|
| (parameterize ((%debug #t)) (animate))
|
| (animate))))
|