From: Ralph Ronnquist Date: Tue, 18 Apr 2023 08:02:23 +0000 (+1000) Subject: Moved DbusInterface to top, to be ued in the loadinng code of Dbus. X-Git-Url: https://git.rrq.au/?a=commitdiff_plain;h=d2f65fd6ffba389bb091e81fe4cca1e29ebf763c;p=rrq%2Flsp-utils.git Moved DbusInterface to top, to be ued in the loadinng code of Dbus. Made :m to expand method calls with signature from members list. Added return signatures to method registrations. --- diff --git a/lsp-dbus/lsp-dbus.lsp b/lsp-dbus/lsp-dbus.lsp index dd75d47..8a4f7c4 100644 --- a/lsp-dbus/lsp-dbus.lsp +++ b/lsp-dbus/lsp-dbus.lsp @@ -14,6 +14,51 @@ (unless (context? MAIN:prog1) (load "misc.lsp")) (unless (context? MAIN:DbusConnection) (load "lsp-dbus-connection.lsp")) +################################################################# +;; The DbusInterface context is used for modelling DBus interfaces. +;; +;; It includes in particular the :use method for installing a +;; DbusInterface FOOP object as a constant named by the interface. +;; E.g. (:use (DbusInterface "org.freedesktop.DBus.ObjectManager") +;; installes the constant ObjectManager with a DbusInterface FOOP +;; object modelling that interface. +;; +;; The :m method is used to construct a fullly qualified method name. +;; E.g. (:m ObjectManager "GetManagedObjects()") assuming the prior +;; :use installation of ObjectManager results in the fully qualified +;; name string +;; "org.freedesktop.DBus.ObjectManager.GetManagedObjects()" +;; +(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 the interface prefix. When +;; the MEMBER is given without "(", then it is duly looked up in the +;; MEMBERS list of the DbusInterface, and it thus gets expanded with +;; parameter signature. +(define (m MEMBER) + (unless (find "(" MEMBER) + (if (ref (string MEMBER "(") (%members) (fn (x y) (starts-with y x)) true) + (setf MEMBER ((parse $it ":") 0)))) + (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))))) + ################################################################# (context 'MAIN:Dbus) @@ -135,13 +180,13 @@ )))) ;; 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)) + DBus (DbusInterface "org.freedesktop.DBus") + APPNAME (if (:invoke ROOT (:m DBus "Hello()")) + ($it -1 -1 -1)) ) ;; Installation of some framework notification handlers @@ -150,9 +195,9 @@ (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) +(:handler ROOT (:m DBus "NameAcquired(s)") signal-trace) +(:handler ROOT (:m DBus "NameLost(s)") signal-trace) +(:handler ROOT (:m DBus "NameOwnerChanged(sss)") signal-trace) ; Process notifications that came with the registration handshake (process-all-pending) @@ -160,30 +205,6 @@ ;; 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 @@ -191,50 +212,50 @@ (context MAIN) (:use (DbusInterface "org.freedesktop.DBus.Peer" - '( "Ping()" - "GetMachineId()" ; s + '( "Ping():" + "GetMachineId():s" ))) (:use (DbusInterface "org.freedesktop.DBus.ObjectManager" - '( "GetManagedObjects()" ; a(oa(sa(sv))) + '( "GetManagedObjects():a(oa(sa(sv)))" ))) (:use (DbusInterface "org.freedesktop.DBus.Introspectable" - ' Introspectable "Introspect()" ; s (xml data) + ' 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 ? + '( "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)" ; ? + '( "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: