X-Git-Url: https://git.rrq.au/?a=blobdiff_plain;f=lsp-dbus%2Flsp-dbus.lsp;h=a8109981268bc9e61fdc1dfb03c602ee529a78f3;hb=fdf17284e8a259e26d70461d9c11a153f9dcca93;hp=98aa0279337987df3dccff9ec16d3c1771fec4ce;hpb=121167c737403e2f49231fd5704aae86850b5b38;p=rrq%2Flsp-utils.git

diff --git a/lsp-dbus/lsp-dbus.lsp b/lsp-dbus/lsp-dbus.lsp
index 98aa027..a810998 100644
--- a/lsp-dbus/lsp-dbus.lsp
+++ b/lsp-dbus/lsp-dbus.lsp
@@ -14,19 +14,64 @@
 (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)
 
 ;; Declaring the FOOP object
-(FOOP path bus)
+(FOOP path name bus)
 
 ;; "The FOOP Constructor". Creates an object for a given path.
-(define (Dbus:Dbus PATH (BUS 'SYSTEM-BUS))
-  (list (context) PATH BUS))
+(define (Dbus:Dbus PATH (NAME (replace "/" (1 PATH) ".")) (BUS 'SYSTEM-BUS))
+  (list (context) PATH NAME BUS))
 
-;; Return the bus name
-(define (bus-name)
-  (join (find-all "([^/]+)" (%path) $1 0) "."))
+;; Method to clone a proxy for a given path/object.
+(define (new-path PATH)
+  (list (context) PATH (%name) (%bus)))
 
 ;; Update the connection serial and return it
 (define (connection++)
@@ -119,13 +164,13 @@
 ;; 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 ((INTERFACE $2) (MEMBER $3) (SIGNATURE $4))
-      ;;(println (list 'invoke (bus-name) INTERFACE MEMBER SIGNATURE))
+  (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 (bus-name))
-                         (list 'PATH (%path))
+                         (list 'DESTINATION (%name))
+                         (list 'PATH (if (empty? PATH) (%path) PATH))
                          (if (empty? INTERFACE) nil
                            (list 'INTERFACE INTERFACE))
                          (list 'MEMBER MEMBER)
@@ -139,13 +184,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
@@ -154,9 +199,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)
@@ -166,62 +211,58 @@
 
 ;;######################################################################
 ;;
-;; Some tidbits
-
-;;org.freedesktop.DBus.Peer.Ping ()
-;;org.freedesktop.DBus.Peer.GetMachineId (out STRING machine_uuid)
-;;org.freedesktop.DBus.Introspectable.Introspect (out STRING xml_data)
-;;org.freedesktop.DBus.Properties.Get (
-;;            in STRING interface_name,
-;;            in STRING property_name,
-;;            out VARIANT value);
-;;org.freedesktop.DBus.Properties.Set (
-;;            in STRING interface_name,
-;;            in STRING property_name,
-;;            in VARIANT value);
-;;org.freedesktop.DBus.Properties.GetAll (
-;;            in STRING interface_name,
-;;            out ARRAY of DICT_ENTRY<STRING,VARIANT> props);
-;;org.freedesktop.DBus.Properties.PropertiesChanged (
-;;            STRING interface_name,
-;;            ARRAY of DICT_ENTRY<STRING,VARIANT> changed_properties,
-;;            ARRAY<STRING> invalidated_properties);
-;;org.freedesktop.DBus.ObjectManager.GetManagedObjects (
-;;            out ARRAY of
-;;               DICT_ENTRY<OBJPATH,ARRAY of
-;;                  DICT_ENTRY<STRING,ARRAY of
-;;                     DICT_ENTRY<STRING,VARIANT>>>
-;;            objpath_interfaces_and_properties);
-;;;;
-;;org.freedesktop.DBus.Hello():s
-;;org.freedesktop.DBus.RequestName(su):u
-;;org.freedesktop.DBus.ReleaseName(s):u
-;;org.freedesktop.DBus.ListQueuedOwners (s):as
-;;org.freedesktop.DBus.ListNames():as
-;;org.freedesktop.DBus.ListActivatableNames():as
-;;org.freedesktop.DBus.NameHasOwner(s):b
-;;org.freedesktop.DBus.NameOwnerChanged(sss) -- signal
-;;org.freedesktop.DBus.NameLost(s) -- signal
-;;org.freedesktop.DBus.NameAcquired(s) -- signal
-;;org.freedesktop.DBus.ActivatableServicesChanged() -- signal
-;;org.freedesktop.DBus.StartServiceByName(s,u):u
-;;org.freedesktop.DBus.UpdateActivationEnvironment(a(ss)):?
-;;org.freedesktop.DBus.GetNameOwner(s):s
-;;org.freedesktop.DBus.GetConnectionUnixUser(s):u
-;;org.freedesktop.DBus.GetConnectionUnixProcessID(s):u
-;;org.freedesktop.DBus.GetConnectionCredentials(s):a(sv)
-;;org.freedesktop.DBus.GetAdtAuditSessionData(s):ay
-;;org.freedesktop.DBus.GetConnectionSELinuxSecurityContext(s):ay
-;;org.freedesktop.DBus.AddMatch(s):? (org.freedesktop.DBus.Error.OOM)
-;;org.freedesktop.DBus.RemoveMatch(s):?
-;;org.freedesktop.DBus.GetId():s
-;;org.freedesktop.DBus.Monitoring.BecomeMonitor(asu):?
-
-;;org.freedesktop.DBus.AddMatch(s)
-;eg 
-;"type='signal',sender='org.example.App2',path_namespace='/org/example/App2'"
+;; Standard interfaces
+
+(context MAIN)
+
+(:use (DbusInterface "org.freedesktop.DBus.Peer"
+                     '( "Ping():"
+                        "GetMachineId():s"
+                        )))
+
+(:use (DbusInterface "org.freedesktop.DBus.ObjectManager"
+                     '( "GetManagedObjects():a(oa(sa(sv)))"
+                        )))
 
-;;org.freedesktop.DBus.StartServiceByName(?)
-;;org.freedesktop.DBus.NameOwnerChanged(?)
+(: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'"
 
 "lsp-dbus.lsp"