From 121167c737403e2f49231fd5704aae86850b5b38 Mon Sep 17 00:00:00 2001 From: Ralph Ronnquist Date: Sat, 15 Apr 2023 23:27:48 +1000 Subject: [PATCH] working snapshot --- Makefile | 19 ++- lsp-dbus-test.lsp | 50 +++----- lsp-dbus/lsp-dbus-connection.lsp | 10 +- lsp-dbus/lsp-dbus-events.lsp | 96 +++++++++++---- lsp-dbus/lsp-dbus-marshal.lsp | 136 ++++++++++++--------- lsp-dbus/lsp-dbus.lsp | 201 +++++++++++++++++++++++-------- lsp-misc/misc.lsp | 4 +- 7 files changed, 345 insertions(+), 171 deletions(-) diff --git a/Makefile b/Makefile index a6575e2..1c3e94c 100644 --- a/Makefile +++ b/Makefile @@ -1,7 +1,18 @@ -LSPLIB = -A lsp-misc/lsp-misc.a -A lsp-dbus/lsp-dbus.a - LSPSRC = lsp-dbus-test.lsp -test0: ${LSPSRC} - ${HOME}/src/borta/packnl/packnl -w $@ $^ ${LSPLIB} +## Library +LSPLIB = lsp-dbus.a + +LSP_MISC = foop.lsp misc.lsp +LSPLIBSRC += $(addprefix lsp-misc/,${LSP_MISC}) + +LSP_DBUS = lsp-dbus-connection.lsp lsp-dbus.lsp lsp-dbus-marshal.lsp +LSP_DBUS += lsp-dbus-events.lsp +LSPLIBSRC += $(addprefix lsp-dbus/,${LSP_DBUS}) + +test0: lsp-dbus-test.lsp ${LSPLIB} + ${HOME}/src/borta/packnl/packnl -w $@ $^ -A ${LSPLIB} + +${LSPLIB}: ${LSPLIBSRC} + ar r $@ $^ diff --git a/lsp-dbus-test.lsp b/lsp-dbus-test.lsp index 0c13db4..82c5ecb 100644 --- a/lsp-dbus-test.lsp +++ b/lsp-dbus-test.lsp @@ -1,39 +1,27 @@ -#!/usr/bin/newlisp - ;; This is a test program for the lsp-dbus provided dbus API. -(load "misc.lsp") (load "lsp-dbus.lsp") -; Log system bus details -(println Dbus:SYSTEM-BUS) -(println (setf ME (Dbus "/au/rrq"))) -(println (setf ROOT (Dbus "/org/freedesktop/DBus"))) +;; Connect to system bus and set up core framework API + +;; Install my own framework object +(die nil (setf au.rrq (Dbus "/au/rrq"))) + +;; Request a bus name +(println (if (:invoke Dbus:ROOT + (print "RequestName(su)") + (println (list (:bus-name au.rrq) 0))) + (!= ($it -1 -1 -1)) ; returns BOOLEAN + )) +(Dbus:process-all-pending) -(define (unpack-messages DATA) - (let ((AT 0) (OUT '()) (M nil) (D nil)) - (while (and (< AT (length DATA)) - (setf M (Dbus:unpack-data "yyyyuua(yv)" DATA AT))) - ;;(println M) - (dotimes (i (length (M 0 -1))) - (setf (M 0 -1 i 0) (Dbus:MESSAGE-HEADERS (M 0 -1 i 0) 0))) - (println M) - (setf AT (M 1)) - (setf S ((lookup 'Dbus:SIGNATURE (M 0 -1)) 0)) - (println "AT=" AT " " (unpack (dup "b" 20) (AT DATA))) - (if (and (< AT (length DATA)) (!= s "")) - (when (setf D (Dbus:unpack-data S DATA AT)) - (println D) - (setf AT (D 1)) - (push (list M (D 0)) OUT -1)) - (push (list M nil) OUT -1)) - (setf DATA (AT DATA)) - (setf AT 0) - ;;(println (octals-string (AT DATA))) - ) - OUT )) +(println (if (:invoke Dbus:ROOT + (print "GetNameOwner(s)") + (println (list "org.bluez"))) + ($it -1 -1 -1) ; Returns value + )) +(Dbus:process-all-pending) -(setf M (:invoke ROOT "Hello" "org.freedesktop.DBus")) -(println (unpack-messages M)) +(reset) ; "lsp-dbus-test.lsp" diff --git a/lsp-dbus/lsp-dbus-connection.lsp b/lsp-dbus/lsp-dbus-connection.lsp index 3ac9b06..f09381b 100644 --- a/lsp-dbus/lsp-dbus-connection.lsp +++ b/lsp-dbus/lsp-dbus-connection.lsp @@ -40,9 +40,13 @@ (define (read-message) (let ((BUFFER "") (RESULT "")) - (while (net-select (%socket) "r" 1000) - (net-receive (%socket) BUFFER 8192) - (extend RESULT BUFFER)) + (while (and RESULT (net-select (%socket) "r" 1000)) + (if (net-receive (%socket) BUFFER 8192) + (extend RESULT BUFFER) + (begin + (setf RESULT nil) + (die 1 "dbus socket closed")) + )) RESULT)) ;; (handshake MSG PAT) diff --git a/lsp-dbus/lsp-dbus-events.lsp b/lsp-dbus/lsp-dbus-events.lsp index 6e93994..3bde661 100644 --- a/lsp-dbus/lsp-dbus-events.lsp +++ b/lsp-dbus/lsp-dbus-events.lsp @@ -1,33 +1,81 @@ ;; This newlisp module implements dbus socket send-receive together -;; with signal receive. -; -; This should be included into the Dbus contect +;; with signal receive. (This file should be loaded into the Dbus +;; context) +;; +;; The REPL loop is re-mastered by means of a prompt-event function +;; that firstly handles any pending dbus messages, and secondly +;; net-select on both the dbus socket and stdin. +;; +;; Stdin is handled with priority. +;; +;; Dbus messages are read and added to the pending list. +;; +;; Handlers are set up as functions (fn (data msg) ..) identified by +;; "dbus callback key" consisting of path, interface, method and +;; signature separated by ":". For example: +;; +;; "/org/freedesktop/DBus:org.freedesktop.DBus.NameAcquired(s)" +;; +;; would identify the handler for the NameAcquired(string) method of +;; the interface "org.freedesktop.DBus" of the path +;; "/org/freedesktop/DBus" of the client. That particular callback is +;; a s.c. signal sent by the dbus framework implementation in reaction +;; to the initial Hello call, i.e. the s.c. invocation of +;; +;; "/org/freedesktop/DBus:org.freedesktop.DBus.Hello()" +;; -(setf pending '()) +;; Return the callback key for a message MSG +(define (message-key MSG) + (string (lookup 'PATH MSG) ":" (lookup 'INTERFACE MSG) "." + (lookup 'MEMBER MSG) "(" (lookup 'SIGNATURE MSG) ")" )) + +;; This is the table of handlers, keyed by path:interface:method:signature +(define RECV:RECV nil) + +;; Utility function to install a handler for a given key, +(define (handler KEY HANDLER) + (RECV (string (%path) ":" KEY) HANDLER)) -(define 'RECV:RECV nil) ; Table of objects that receive calls/signals +;; This is the list of Dbus messages still to handle. +(setf pending '()) -(define (set-object PATH HANDLER) (RECV PATH HANDLER)) +(define (no-handler KEY MSG) + (write-line 2 (format "** No handler %s for:\n%s" KEY (string MSG)))) -(define (process-signal DATA) - (let ((MSG (unpack-message "uuuuyya(yv)" DATA))) - ;; Determine object concerned - ;; Determine that object's handler for this signal - ;; Call the handler with signal data - )) +(define (process-message MSG) + ;;(die nil (list 'process-message MSG)) + (let ((KEY (message-key MSG))) + ;;(die nil "Dbus:process-message" KEY (and (RECV KEY) true)) + (if (RECV KEY) ($it (lookup "" MSG)) + (no-handler KEY MSG)))) -(define (send-recv--message MSG) - ;; Pack the message into a data block - (:send-message SYSTEM-SOCKET) - (while (unrelated (setf MSEG (:read-message SYSTEM-BUS ))) - (push MSG pending -1)) - MSG) +;; Process all messages currently pending +(define (process-all-pending) + (while (if (pop pending) (process-message $it)))) ;; The main-loop is intended as a prompt-handler so as to deal with ;; asyncronous events -(define (main-loop) - (let ((FDS (list 0 (:%socket SYSTEM-BUS)))) - (while (and (empty? pending) (not (member 0 (net-select FDS "r" -1)))) - (if (pop pending) (process-signal $it) - (if (:read-message SYSTEM-BUS) (push $it pending -1))) - ))) \ No newline at end of file +(define (main-loop S) + (let ((FDS (list 0 (:%socket SYSTEM-BUS))) (FD nil)) + ;;(die nil "Dbus:main-loop" (length pending) "pending") + (write 2 (string "> ")) + (while (or pending (not (member 0 (net-select FDS "r" -1)))) + (if (pop pending) (process-message $it) + (if (unpack-messages (or (:read-message SYSTEM-BUS) "")) + (extend pending $it)) + )) + "main-loop: ")) + +;; Send message, then keep reading messages until there is a reply +(define (send-recv-message MSG) + ;;(die nil (list 'send-recv-message (octals-string MSG))) + (net-send (:%socket SYSTEM-BUS) MSG) + (let ((REPLY nil)) + (while (nil? REPLY) + (dolist (M (unpack-messages (:read-message SYSTEM-BUS))) + (if (lookup 'REPLY_SERIAL M) (setf REPLY M) + (push M pending -1)))) + REPLY)) + +"lsp-dbus-events.lsp" diff --git a/lsp-dbus/lsp-dbus-marshal.lsp b/lsp-dbus/lsp-dbus-marshal.lsp index 4e72ef6..81b6aa5 100644 --- a/lsp-dbus/lsp-dbus-marshal.lsp +++ b/lsp-dbus/lsp-dbus-marshal.lsp @@ -1,24 +1,22 @@ ;; This newlisp "module" implements dbus marshalling ; ; The newlisp representation is a simplified form using lists for -; structs and arrays +; structs and arrays. -;;================ +;; (expand-signature S) ; Expland a signature string into a nested list to correspond to the -; newlisp list representation. Basic dbus types are basic newlisp -; types, including strings. Arrays and structs are sublists. The -; signature marks array sublists with an initial "a", otherwise it's a -; struct sublist. +; newlisp list representation. +;; Basic dbus types are basic newlisp types, including strings. Arrays +;; and structs are sublists; the expanded signature marks array +;; sublists with an initial "a", otherwise it's a struct sublist. ; ; Ex: "yi" = ("y" "i") ; Ex: "y(ai)" = ("y" (("a" "i"))) ; Ex: "a(yi)" = (("a" ("y" "i"))) ; Ex: "yyyyuua(yv)" = ("y" "y" "y" "y" "u" "u" ("a" ("y" "v"))) (define (expand-signature S) - (println (list 'expand-signature S)) (let ((STACK '()) (CUR '()) (A 0)) (dolist (X (explode S)) - ;;(println "CUR=" CUR " X=" X) (case X (")" (setf X CUR) (setf CUR (pop STACK))) ("(" (push CUR STACK) (setf CUR '())) @@ -29,39 +27,21 @@ (setf CUR (chop CUR)))) (when (!= "(" X) (push X CUR -1))) - (if (null? CUR) '() (1 CUR) CUR (CUR 0)) )) - -;; Join arguments with a given byte-alignment -(define (pad-join N) - ;;(println (list 'pad-join AT N (args))) - (let ((OUT "")) - (dolist (S (args)) - (let ((PAD (dup "\000" (% (- N (% (length OUT) N)) N)))) - (extend OUT PAD S))) - OUT)) - -;; Pack data from DATA according to signature. The DATA is a nested -;; list where container types are sub lists. Variant types also appear -;; as pairs of signature and value. -(define (pack-data SIGN DATA) - (let ((AT 0)) (pack-data-struct (expand-signature SIGN) DATA))) + (if (null? CUR) '() CUR))) -;; Align AT to an I multiple by adding nul bytes, then extend it with -;; DATA, and increment AT +;; Align AT to an I multiple and pad DATA with as many NUL bytes at +;; front, then increment AT past it all. (define (pack-align DATA (I (length DATA))) (let ((PAD (dup "\000" (% (- I (% AT I)) I)))) - ;;(println (list 'align AT I (length PAD))) (setf DATA (extend PAD DATA)) (inc AT (length DATA)) DATA)) -;; Advance AT to align by I -(define (align-unpack I FMT N) - ((list (inc AT (% (- I (% AT I)) I)) ; align to I - (unpack FMT (AT DATA)) - (inc AT N)) - 1 0)) ; return second term's first item - +;; Pack data from DATA according to signature. The DATA is a nested +;; list where container types are sub lists. Variant types also appear +;; as pairs of signature and value. +(define (pack-data SIGN DATA) + (let ((AT 0)) (pack-data-struct (expand-signature SIGN) DATA))) ;; Pack a newlisp data element according to marshalling type The ;; newlisp data is integer, double, string or list (for container and @@ -99,24 +79,28 @@ ) (define (pack-data-item ES DATA) - ;;(println (list 'pack-data-item AT ES DATA)) (if (list? ES) (pack-data-struct ES DATA) - (find ES "osg") (pack-data-string ES DATA) + (= ES "s") (pack-data-string ES DATA) + (= ES "o") (pack-data-string ES DATA) + (= ES "g") (pack-data-signature ES DATA) (= ES "v") (apply pack-data-variant DATA) (if (lookup ES FMTMAP) (pack-align (pack $it DATA))))) (define (pack-data-variant ES DATA) - ;;(println (list 'pack-data-variant AT ES DATA)) (extend (pack-align (pack "bbb" 1 (char ES) 0) 1) (pack-data-item ES DATA))) +;; pack types "s" and "o" (define (pack-data-string ES DATA) - (pack-align (pack (format "lus%db" (length DATA)) (length DATA) DATA 0) 1)) + (pack-align (pack (format "lus%db" (length DATA)) (length DATA) DATA 0) 4)) + +;; pack type "g" +(define (pack-data-signature ES DATA) + (pack-align (pack (format "bs%db" (length DATA)) (length DATA) DATA 0) 1)) ;; Pack an array. DATA elements marshalled by repeating ES, preceded ;; by the array length in bytes as aligned UINT32. (define (pack-data-array ES DATA) - ;;(println (list 'pack-data-array AT ES DATA)) (let ((PAD (pack-align "" 4)) (X (inc AT 4)) ; start index of array bytes (DATA (apply extend (map (curry pack-data-item ES) DATA)))) @@ -125,48 +109,61 @@ ;; Pack a struct. ES and DATA elements marshalled pairwise in order ;; following an initial8-byte alignment. (define (pack-data-struct ES DATA) - ;;(println (list 'pack-data-struct AT ES DATA)) - (if (= "a" (ES 0)) - (pack-data-array (ES 1) DATA) + (if (= "a" (ES 0)) (pack-data-array (ES 1) DATA) (apply extend (cons (pack-align "" 8) (map pack-data-item ES DATA))))) ;;########## unpacking +;; Advance AT to an I multiple. (define (align-AT I) (inc AT (% (- I (% AT I)) I))) +;; Advance AT to an I multiple and unpack (by newlisp format) at that +;; position in DATA. Then advance AT further past that unpacking but +;; return the unpacked value. (define (unpack-align I FMT) (align-AT I) (prog1 ((unpack FMT (AT DATA)) 0) (inc AT I))) -(define (unpack-data-string ES) - ;;(println (list 'unpack-data-string ES AT (unpack "bbbb" (AT DATA)))) - (let ((N (if (= "g" ES) (unpack-align 1 "b") (unpack-align 4 "lu")))) - (prog1 (unpack (string "s" N) (AT DATA)) (inc AT (+ 1 N))))) - +;; Unpack a string or object path. The format is "lu" (UINT32) with +;; the string length, then "s%db" with that string length and followed +;; by a NUL byte. +(define (unpack-data-string ES (N (unpack-align 4 "lu"))) + (prog1 ((unpack (string "s" N) (AT DATA)) 0) (inc AT (+ 1 N)))) + +;; Unpack a signature string. The format is "b" (BYTE) with the string +;; length, then "s%db" with that string length and followed by a NUL +;; byte. I.e. the same as unpack-data-string but with the string +;; length in a BYTE rather than an UINT32. +(define (unpack-data-signature ES) + (unpack-data-string ES (unpack-align 1 "b"))) + +;; Unpack a variant item. This consists of "bbb" where the middle +;; character is the type character for the data, preceded by a 1 byte +;; and followed by a NUL byte. The subsequent data is unpacked +;; according to that type character. (define (unpack-data-variant) - ;;(println (unpack "bbbb" (AT DATA))) - (let ((ES (char ((unpack "bbb" (AT DATA)) 1)))) + (let ((ES ((unpack "bs1b" (AT DATA)) 1))) (inc AT 3) (unpack-data-item ES))) -;; Unpack the ES item from (AT DATA) and increment AT +;; Unpack the ES type item from (AT DATA), optionally with +;; pre-alignment, and increment AT past the padding and item. (define (unpack-data-item ES) - ;;(println (list 'unpack-data-item ES AT (unpack "b" (AT DATA)))) - ;;(when (= ES "\000") (println (history true))) (if (list? ES) (unpack-data-struct ES) - (find ES "+gosg") (unpack-data-string ES) + (= ES "s") (unpack-data-string ES) + (= ES "o") (unpack-data-string ES) + (= ES "g") (unpack-data-signature ES) (= ES "v") (unpack-data-variant) (if (assoc ES FMTMAP) (unpack-align ($it -2) ($it -1))))) ;; Unpack array with ES elements. The array begins with an UINT32 -;; field telling how many bytes to unpack +;; field telling how many bytes to unpack, followed by the array +;; elements. (define (unpack-data-array ES) - ;;(println (list 'unpack-data-array ES)) (let ((A AT) (N (+ (unpack-align 4 "u") AT)) (OUT '())) (while (< AT N) - ;;(println (list 'item AT N)) (push (unpack-data-item ES) OUT -1)) OUT)) @@ -179,7 +176,30 @@ ;; a pair (unpacked pos) of unpacked data and how much data is ;; consumed. (define (unpack-data SIGN DATA (AT 0)) - ;;(println (list 'unpack-data SIGN "DATA length " (length DATA))) - ;;(map println (explode (unpack (dup "b" (length (AT DATA))) (AT DATA)) 20)) (list (unpack-data-item (expand-signature SIGN)) AT)) +;; Unpack all dbus messages in the given DATA block. Each message +;; consists of head and body. The head has signature "yyyyuua(yv)" +;; where the array is an alist of key-value pairs, optionally +;; including the 'SIGNATURE key with the signature for the body; if +;; omitted, then the body is empty. +;; +;; The function returns the header list of key-value pairs optionally +;; extended with the pair ("" body). +(define (unpack-messages DATA) + (let ((AT 0) (OUT '()) (M nil) (D nil) (S nil)) + (while (and (< AT (length DATA)) + (setf M (unpack-data "yyyyuua(yv)" DATA AT))) + (setf AT (M 1)) + (setf M (M 0 -1)) ; Drop + (dotimes (i (length M 0)) + (setf (M i 0) (MESSAGE-HEADERS (M i 0) 0))) + (setf S (if (lookup 'SIGNATURE M) ($it 0) "")) + (when (and (!= S "") (setf D (unpack-data S DATA AT))) + (setf AT (D 1)) + (extend M (list (list "" (D 0))))) + (push M OUT -1) + (setf DATA (AT DATA)) + (setf AT 0) + ) + OUT )) diff --git a/lsp-dbus/lsp-dbus.lsp b/lsp-dbus/lsp-dbus.lsp index e40c2eb..98aa027 100644 --- a/lsp-dbus/lsp-dbus.lsp +++ b/lsp-dbus/lsp-dbus.lsp @@ -11,22 +11,16 @@ ;; (unless (context? MAIN:FOOP) (load "foop.lsp")) +(unless (context? MAIN:prog1) (load "misc.lsp")) (unless (context? MAIN:DbusConnection) (load "lsp-dbus-connection.lsp")) ################################################################# (context 'MAIN:Dbus) -; Include marshalling functions -(load "lsp-dbus-marshal.lsp" MAIN:Dbus) - ;; Declaring the FOOP object (FOOP path bus) - -(setf SYSTEM-BUS (MAIN:DbusConnection "/run/dbus/system_bus_socket")) -(:initialize SYSTEM-BUS) - -;; "Constructor". Creates an adapter object for a given base path. +;; "The FOOP Constructor". Creates an object for a given path. (define (Dbus:Dbus PATH (BUS 'SYSTEM-BUS)) (list (context) PATH BUS)) @@ -34,12 +28,18 @@ (define (bus-name) (join (find-all "([^/]+)" (%path) $1 0) ".")) -;; Return the DbusConnection connection adapter -(define (connection) - (eval (%bus))) +;; Update the connection serial and return it +(define (connection++) + (case (%bus) + (SYSTEM-BUS (:serial++ SYSTEM-BUS)) + (true 0))) + +; Include marshalling functions and signal handling framework +(load "lsp-dbus-marshal.lsp" (context)) +(load "lsp-dbus-events.lsp" (context)) ;; ==================== -;; Dbus messages +;; Dbus symbols (constant 'PROTOCOL-VERSION '(1 1) @@ -47,7 +47,7 @@ 'MESSAGE-FLAGS '(NO_REPLY_EXPECTED NO_AUTO_START ALLOW_INTERACTIVE_AUTHORIZATION) - ;; Message headers: [code] (name type) + ;; Message headers: [code] => (name type) 'MESSAGE-HEADERS '((INVALID ) (PATH "o") (INTERFACE "s") @@ -61,20 +61,21 @@ ) ) -;; Determine the type code = index of teh type symbol in the -;; MESSAGE-TYPES list. +;; Map message type symbol to dbus type code (i.e. the list index) (define (message-type-code TYPE) (or (find TYPE MESSAGE-TYPES =) 0)) +;; Map flag symbol F to its dbus "bit code" (define (flag F) (if (find F MESSAGE-FLAGS) (pow 2 $it) 0)) -;; Combining header flag symbols into the flags code = bit-or of the -;; 2^x values where x is the index for the flag symbol in the -;; MESSAGE-FLAGS list. +;; Return the dbus flags code from FLAGS; if it is a number thent tha +;; is returned as is; if FLAGS is a list of message flag symbols then +;; combine their codes by bit-OR. Anything else yields 0. (define (message-flags FLAGS) (if (number? FLAGS) FLAGS - (list? FLAGS) (apply | (map flag FLAGS)) + (list? FLAGS) + (apply | (map flag FLAGS)) 0)) ;; (message-header (NAME VALUE)) @@ -82,10 +83,19 @@ ; its header code and associated value type. This gets translated into ; the marshalling data form of (code (type value)) (define (message-header HDR) - (let ((CODE (find (list (HDR 0) '*) MESSAGE-HEADERS match) 0)) - (list CODE (list (MESSAGE-HEADERS CODE 1) (HDR 1))))) - -;; Return a marshalled message + (when (list? HDR) + (if (find (list (HDR 0) '*) MESSAGE-HEADERS match) + (list $it (list (MESSAGE-HEADERS $it -1) (HDR 1)))))) + +;; Join the excess string arguments N-byte alignment successively +(define (pad-join N) + (let ((OUT "")) + (dolist (S (args)) + (let ((PAD (dup "\000" (% (- N (% (length OUT) N)) N)))) + (extend OUT PAD S))) + OUT)) + +;; Return a marshalled message string appended by the marshalled body (define (message TYPE FLAGS HDRS BODY) (pad-join 8 (pack-data "yyyyuua(yv)" @@ -94,31 +104,124 @@ (message-flags FLAGS) (PROTOCOL-VERSION 0) ; Major version code (length BODY) - (:serial++ (connection)) - (map message-header HDRS))) - BODY)) - -(define (method-body ARGS) - "") - -;; Invoke a method on an object via dbus -; (:invoke OBJ MEMBER INTERFACE FLAGS) -(define (invoke MEMBER INTERFACE (FLAGS 0)) - (or INTERFACE (setf INTERFACE (bus-name))) - (if (message 'METHOD_CALL FLAGS - (list (list 'PATH (%path)) - (list 'DESTINATION (bus-name)) - (list 'INTERFACE INTERFACE) - (list 'MEMBER MEMBER)) - (method-body (args))) - (begin - (let ((MSG $it) (BUFFER "") (RESULT "") (S (:%socket (connection)))) - (net-send S MSG) - (while (net-select S "r" 1000) - (net-receive S BUFFER 8192) - (extend RESULT BUFFER)) - BUFFER)) - nil - )) + (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 ((INTERFACE $2) (MEMBER $3) (SIGNATURE $4)) + ;;(println (list 'invoke (bus-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)) + (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) + +;;###################################################################### +;; +;; 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 props); +;;org.freedesktop.DBus.Properties.PropertiesChanged ( +;; STRING interface_name, +;; ARRAY of DICT_ENTRY changed_properties, +;; ARRAY invalidated_properties); +;;org.freedesktop.DBus.ObjectManager.GetManagedObjects ( +;; out ARRAY of +;; DICT_ENTRY>> +;; 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'" + +;;org.freedesktop.DBus.StartServiceByName(?) +;;org.freedesktop.DBus.NameOwnerChanged(?) "lsp-dbus.lsp" diff --git a/lsp-misc/misc.lsp b/lsp-misc/misc.lsp index cf92d9c..f60d0d3 100644 --- a/lsp-misc/misc.lsp +++ b/lsp-misc/misc.lsp @@ -3,7 +3,7 @@ (define (die N) (when (args) (write-line 2 (join (map string (args)) " "))) - (exit N)) + (and N (exit N))) (global 'die) ;; Print binary byte as octal or as ASCII character [32-126] @@ -12,5 +12,5 @@ ;; Print string as binary octals (define (octals-string S) - (join (map octal-byte (unpack (dup "b" (length S)) S))) "") + (join (map octal-byte (unpack (dup "b" (length S)) S)))) (global 'octals-string 'octal-byte) -- 2.39.2