-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 $@ $^
-#!/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"
(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)
;; 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"
;; 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 '()))
(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
)
(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))))
;; 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))
;; 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 ))
;;
(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))
(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)
'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")
)
)
-;; 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))
; 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)"
(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<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'"
+
+;;org.freedesktop.DBus.StartServiceByName(?)
+;;org.freedesktop.DBus.NameOwnerChanged(?)
"lsp-dbus.lsp"
(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]
;; 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)
projects / rrq / lsp-utils.git / commitdiff