+ (connection++)
+ (clean null? (map message-header HDRS))))
+ BODY ))
+
+;; (:invoke OBJ METHOD ARGS FLAGS)
+; Perform a METHOD_CALL on the (self) object
+;; The given METHOD has format "INTERFACE.NAME(SIGNATURE)" with the
+;; "INTERFACE." bit optional. The function returns the list of headers
+;; of the reply message extended with reply value as a faked header
+;; named "".
+;;
+;; This function calls send-recv-message which also polls for signals
+;; until a reply is given, but any such signals are stocked up as
+;; pending for later processing on demand.
+(define (invoke METHOD ARGS (FLAGS 0))
+ (when (regex "((.+):)?((.+)\\.)?([^(]+)\\((.*)\\)$" METHOD 0)
+ (let ((PATH $2) (INTERFACE $4) (MEMBER $5) (SIGNATURE $6))
+ ;;(println (list 'invoke (%name) INTERFACE MEMBER SIGNATURE))
+ (if (message 'METHOD_CALL FLAGS
+ (list nil ; (if SELF-NAME (list 'SENDER SELF-NAME))
+ (list 'DESTINATION (%name))
+ (list 'PATH (if (empty? PATH) (%path) PATH))
+ (if (empty? INTERFACE) nil
+ (list 'INTERFACE INTERFACE))
+ (list 'MEMBER MEMBER)
+ (if (empty? SIGNATURE) nil
+ (list 'SIGNATURE SIGNATURE))
+ )
+ (if (empty? SIGNATURE) ""
+ (pack-data SIGNATURE ARGS)))
+ (send-recv-message $it)
+ nil
+ ))))
+
+;; Context variables and framework registration
+
+(setf
+ SYSTEM-BUS (MAIN:DbusConnection "/run/dbus/system_bus_socket")
+ APPID (:initialize SYSTEM-BUS)
+ ROOT (Dbus "/org/freedesktop/DBus")
+ APPNAME (if (lookup "" (:invoke ROOT "org.freedesktop.DBus.Hello()"))
+ ($it 0))
+ )
+
+;; Installation of some framework notification handlers
+
+;; Helper method to notify
+(define (signal-trace ARGS)
+ (die nil "** Got:" KEY ARGS ))
+
+(:handler ROOT "org.freedesktop.DBus.NameAcquired(s)" signal-trace)
+(:handler ROOT "org.freedesktop.DBus.NameLost(s)" signal-trace)
+(:handler ROOT "org.freedesktop.DBus.NameOwnerChanged(sss)" signal-trace)
+
+ ; Process notifications that came with the registration handshake
+(process-all-pending)
+
+;; Set up the Dbus event loop as prompt-event handler
+(prompt-event Dbus:main-loop)
+
+(context 'DbusInterface)
+(FOOP name members)
+
+;; FOOP constructor; remember the interface name
+(define (DbusInterface:DbusInterface NAME (MEMBERS '()))
+ (list (context) NAME MEMBERS))
+
+;; Utility method to expand a member with interface prefix
+(define (m MEMBER)
+ (string (%name) "." MEMBER))
+
+;; Install this interface into the context of the caller
+(define (use)
+ (let ((IF (when (regex "([^.]+)$" (%name) 0) $1))
+ (CC (prefix (first (or (1 (history)) '(MAIN))))))
+ (letex ((S (sym $1 CC)) (V (self)))
+ (begin (context CC) (constant 'S 'V)))))
+
+;; Declare additional members for this interface
+(define (has)
+ (dolist (MEMBER (args))
+ (unless (member MEMBER (%members))
+ (!members (push MEMBER (%members) -1)))))
+
+;;######################################################################
+;;
+;; Standard interfaces
+
+(context MAIN)
+
+(:use (DbusInterface "org.freedesktop.DBus.Peer"
+ '( "Ping()"
+ "GetMachineId()" ; s
+ )))
+
+(:use (DbusInterface "org.freedesktop.DBus.ObjectManager"
+ '( "GetManagedObjects()" ; a(oa(sa(sv)))
+ )))
+
+(:use (DbusInterface "org.freedesktop.DBus.Introspectable"
+ ' Introspectable "Introspect()" ; s (xml data)
+ ))
+; https://dbus.freedesktop.org/doc/dbus-specification.html#introspection-format
+
+(:use (DbusInterface "org.freedesktop.DBus.Properties"
+ '( "Get(ss)" ; v
+ "Set(ssv)" ; --
+ "GetAll(s)" ; a(sv)
+ "PropertiesChanged(sa(sv)as)" ; signal ?
+ )))
+
+(:use (DbusInterface "org.freedesktop.DBus"
+ '( "Hello()" ; s
+ "RequestName(su)" ; u
+ "ReleaseName(s)" ; u
+ "ListQueuedOwners (s)" ; as
+ "ListNames()" ; as
+ "ListActivatableNames()" ; as
+ "NameHasOwner(s)" ; b
+ "NameOwnerChanged(sss)" ; -- signal
+ "NameLost(s)" ; -- signal
+ "NameAcquired(s)" ; -- signal
+ "ActivatableServicesChanged()" ; -- signal
+ "StartServiceByName(s,u)" ; u
+ "UpdateActivationEnvironment(a(ss))" ; ?
+ "GetNameOwner(s)" ; s
+ "GetConnectionUnixUser(s)" ; u
+ "GetConnectionUnixProcessID(s)" ; u
+ "GetConnectionCredentials(s)" ; a(sv)
+ "GetAdtAuditSessionData(s)" ; ay
+ "GetConnectionSELinuxSecurityContext(s)" ; ay
+ "AddMatch(s)" ;
+ "RemoveMatch(s)" ; ?
+ "GetId()" ; s
+ "Monitoring.BecomeMonitor(asu)" ; ?
+ )))
+
+;eg AddMatch argument:
+;"type='signal',sender='org.example.App2',path_namespace='/org/example/App2'"