--- /dev/null
+# Create the newlisp library dbus.lsplib
+
+ARCHIVES = lsp-dbus.a
+
+DOCS = ${ARCHIVES:=.8.adoc}
+
+default: ${ARCHIVES} ${DOCS}
+
+%: %.adoc
+ asciidoctor -b manpage $<
+
+clean:
+ rm -f ${ARCHIVES} ${DOCS}
+
+lsp-dbus.a: lsp-dbus-connection.lsp lsp-dbus.lsp lsp-dbus-marshal.lsp
+lsp-dbus.a: lsp-dbus-events.lsp
+ ar rc $@ $^
--- /dev/null
+;; This newlisp "module" sets up a dbus API adapter
+;;
+;; dbus is an object oriented interprocess commmunications framework
+;; based on utual object proxying. This end holds some objects that
+;; remote ends can access and invoke methods on, and remote ends hold
+;; objects that this pocess can access and invoke methods on.
+;;
+;; https://dbus.freedesktop.org/doc/dbus-specification.html
+;; https://dbus.freedesktop.org/doc/dbus-api-design.html
+;; [C API] https://dbus.freedesktop.org/doc/api/html/
+;;
+
+; Require the FOOP context
+(unless (context? MAIN:FOOP) (load "foop.lsp"))
+
+#################################################################
+;; This newlisp module implements dbus socket connection
+;;
+
+(context 'MAIN:DbusConnection)
+(FOOP path socket name serial)
+
+(define (DbusConnection:DbusConnection PATH)
+ (list (context) PATH -1 nil 0))
+
+;; Increment the serial and return it.
+(define (serial++)
+ (!serial (+ 1 (%serial))))
+
+;; (open-socket)
+; Internal utility method to re-open the %path socket and set the
+; %socket field.
+(define (open-socket)
+ (when (>= (%socket))
+ (close (%socket))
+ (!socket -1))
+ (!socket (net-connect (%path))))
+
+;** Commands from client to server
+; AUTH [mechanism] [initial-response]
+; CANCEL
+; BEGIN
+; DATA <data in hex encoding>
+; ERROR [human-readable error explanation]
+; NEGOTIATE_UNIX_FD
+
+;** Commands from server to client
+; REJECTED <space-separated list of mechanism names>
+; OK <GUID in hex>
+; DATA <data in hex encoding>
+; ERROR [human-readable error explanation]
+; AGREE_UNIX_FD
+
+(define (read-message)
+ (let ((BUFFER "") (RESULT ""))
+ (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)
+; Perform a socket handshake sending MSG and return the result, or if
+; PAT not nil, then return (regex PAT RESULT 0),
+(define (handshake MSG PAT)
+ (let ((RESULT ""))
+ (net-send (%socket) MSG)
+ (setf RESULT (read-message))
+ (if PAT (regex PAT RESULT 0) RESULT)))
+
+(constant
+ 'AUTHFMT "AUTH EXTERNAL %s\r\n"
+ 'AUTHACK "OK (\\S+)\r\n"
+ 'KEEPFMT "NEGOTIATE_UNIX_FD\r\n"
+ 'KEEPACK "AGREE_UNIX_FD\r\n"
+ )
+
+;; (initialize USER)
+; Perform socket initialization sequence and return the name, or nil.
+(define (initialize (USER (env "USER")))
+ (when (and (>= (open-socket))
+ (net-send (%socket) (char 0))
+ (handshake (format AUTHFMT (char2hex USER)) AUTHACK)
+ (!name $1)
+ (handshake KEEPFMT KEEPACK))
+ (handshake "BEGIN\r\n")
+ (%name)))
+
+(define (cancel)
+ (handshake "CANCEL\r\n" "(.*)"))
+
+#################################################################
+;; 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 'MAIN: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 name bus)
+
+;; "The FOOP Constructor". Creates an object for a given path.
+(define (Dbus:Dbus PATH (NAME (replace "/" (1 PATH) ".")) (BUS 'SYSTEM-BUS))
+ (list (context) PATH NAME BUS))
+
+;; 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++)
+ (case (%bus)
+ (SYSTEM-BUS (:serial++ SYSTEM-BUS))
+ (true 0)))
+
+; marshalling functions and signal handling framework
+;; This newlisp "module" implements dbus marshalling
+;
+; The newlisp representation is a simplified form using lists for
+; 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 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)
+ (setf S (replace "{" (replace "}" (copy S) ")") "("))
+ (let ((STACK '()) (CUR '()) (A 0))
+ (dolist (X (explode S))
+ (case X
+ (")" (setf X CUR) (setf CUR (pop STACK)))
+ ("(" (push CUR STACK) (setf CUR '()))
+ (true true))
+ (when (and (!= X "a") (!= X "("))
+ (while (and CUR (= "a" (last CUR)))
+ (setf X (list (last CUR) X))
+ (setf CUR (chop CUR))))
+ (when (!= "(" X)
+ (push X CUR -1)))
+ (if (null? CUR) '() CUR)))
+
+;; 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))))
+ (setf DATA (extend PAD DATA))
+ (inc AT (length DATA))
+ DATA))
+
+;; 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
+;; variant elements).
+(constant
+ 'FMTMAP ; mapping dbus type code to byte size and newlisp code
+ '( ("y" 1 "b") ; BYTE (unsigned 8-bit integer)
+ ("b" 4 "lu") ; BOOLEAN (0 is FALSE, 1 is TRUE, else invalid)
+ ("n" 2 "d") ; INT16 (signed 16-bit integer)
+ ("q" 2 "u") ; UINT16 (unsigned 16-bit integer)
+ ("i" 4 "ld") ; INT32 (signed 32-bit integer)
+ ("u" 4 "lu") ; UINT32 (unsigned 32-bit integer)
+ ("x" 8 "Ld") ; INT64 (signed 64-bit integer)
+ ("t" 8 "Lu") ; UINT64 (unsigned 64-bit integer)
+ ("d" 8 "lf") ; DOUBLE (64-bit float)
+ ("h" 4 "lu") ; UINT32 (unix file descriptor)
+ ("a" ? ?) ; ARRAY = UINT32 byte-length, items
+ ("s" ? ?) ; STRING = length + data + NUL
+ ("o" ? ?) ; OBJECT_PATH = BYTE length + data + NUL
+ ("g" ? ?) ; SIGNATURE = BYTE length + data + NUL
+ ("(" ? ?) ; STRUCT begin in signature = (8-align) + data
+ (")" 0 ?) ; STRUCT end in signature
+ ("v" ? ?) ; VARIANT = signature + data
+ ("{" ? ?) ; DICT_ENTRY begin
+ ("}" ? ?) ; DICT_ENTRY end
+ ("r" ? ?) ; reserved STRUCT in bindings?
+ ("e" ? ?) ; reserved DICT_ENTRY in bindings ?
+ ("m" ? ?) ; reserved 'maybe'
+ ("*" ? ?) ; reserved 'single complete type'
+ ("?" ? ?) ; reserved 'basic type'
+ ("@" ? ?) ; reserved
+ ("&" ? ?) ; reserved
+ ("^" ? ?) ; reserved
+ )
+ )
+
+(define (pack-data-item ES DATA)
+ (if (list? ES) (pack-data-struct 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)
+ (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) 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)
+ (let ((PAD (pack-align "" 4))
+ (X (inc AT 4)) ; start index of array bytes
+ (DATA (apply extend (map (curry pack-data-item ES) DATA))))
+ (extend PAD (pack "lu" (- AT X)) DATA)))
+
+;; Pack a struct. ES and DATA elements marshalled pairwise in order
+;; following an initial8-byte alignment.
+(define (pack-data-struct ES 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)
+ ##(println (list 'unpack-align I FMT AT (length DATA)))
+ (align-AT I)
+ ((fn (X) X) ((unpack FMT (AT DATA)) 0) (inc AT I)))
+
+;; 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")))
+ ((fn (X) X) ((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)
+ (unpack-data-item ((expand-signature (unpack-data-signature "g")) 0)))
+
+;; 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 (length DATA)))
+ (if (list? ES) (unpack-data-struct 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, followed by the array
+;; elements.
+(define (unpack-data-array ES)
+ (let ((A AT) (N (+ (unpack-align 4 "u") AT)) (OUT '()))
+ (when (and (list? ES) (!= "a" (ES 0))) (align-AT 8))
+ (while (< AT N)
+ ##(println "---next " (list AT N))
+ (push (unpack-data-item ES) OUT -1))
+ OUT))
+
+;; Unpack a structure or array with ES fields.
+(define (unpack-data-struct ES)
+ ##(println (list 'unpack-data-struct ES AT))
+ (if (= "a" (ES 0)) (unpack-data-array (ES 1))
+ (begin (align-AT 8) (map unpack-data-item ES))))
+
+;; Unpack from a DATA string according to signature SIGN This returns
+;; a pair (unpacked pos) of unpacked data and how much data is
+;; consumed.
+(define (unpack-data SIGN DATA (AT 0))
+ ##(println (format "*** unpack-data %s %d %d" SIGN (length DATA) AT))
+ (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 7) (length DATA))
+ (setf M (unpack-data "yyyyuua(yv)" DATA AT)))
+ (setf AT (M 1))
+ ##(println "message head " (M 0))
+ ##(println (list 'remains AT (length DATA)))
+ (setf M (M 0 -1)) ; Drop all but the headers then map to symbol keys
+ (dotimes (i (length M))
+ (setf (M i 0) (MESSAGE-HEADERS (M i 0) 0)))
+ ##(println "mapped headers " M)
+ ;; Add the body, if any, keyed by "".
+ (setf S (if (lookup 'SIGNATURE M) $it ""))
+ ##(println (list 'sign S))
+ (when (and (!= S "") (setf D (unpack-data S DATA AT)))
+ (setf AT (D 1))
+ (extend M (list (list "" (D 0)))))
+ ;; Collate message and move to the next portion in DATA
+ (push M OUT -1)
+ ##(println (list 'ending AT (length DATA)))
+ ;;(align-AT 4)
+ ##(println (list 'aligned AT (length DATA)))
+ (setf DATA (AT DATA))
+ (setf AT 0)
+ )
+ OUT ))
+
+#################################################################
+;; This newlisp module implements dbus socket send-receive together
+;; 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()"
+;;
+
+;; 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))
+
+;; This is the list of Dbus messages still to handle.
+(setf pending '())
+
+(define (no-handler KEY MSG)
+ (write-line 2 (format "** No handler %s for:\n%s" KEY (string MSG))))
+
+(define (process-message MSG)
+ (let ((KEY (message-key MSG)))
+ (if (RECV KEY) ($it (lookup "" MSG))
+ (no-handler KEY 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 S)
+ (let ((FDS (list 0 (:%socket SYSTEM-BUS))) (FD nil))
+ (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: "))
+
+(define (human-msg MSG)
+ (human-bytes (unpack (dup "b" (length MSG)) MSG)))
+
+;; Send message, then keep reading messages until there is a reply
+(define (send-recv-message MSG)
+ ;;(die nil (list 'send-recv-message (human-msg 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))
+
+
+;; ====================
+;; Dbus symbols
+
+(constant
+ 'PROTOCOL-VERSION '(1 1)
+ 'MESSAGE-TYPES '(INVALID METHOD_CALL METHOD_RETURN ERROR SIGNAL)
+ 'MESSAGE-FLAGS '(NO_REPLY_EXPECTED
+ NO_AUTO_START
+ ALLOW_INTERACTIVE_AUTHORIZATION)
+ ;; Message headers: [code] => (name type)
+ 'MESSAGE-HEADERS '((INVALID )
+ (PATH "o")
+ (INTERFACE "s")
+ (MEMBER "s")
+ (ERROR_NAME "s")
+ (REPLY_SERIAL "i")
+ (DESTINATION "s")
+ (SENDER "s")
+ (SIGNATURE "g")
+ (UNIX_FDS "i")
+ )
+ )
+
+;; 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))
+
+;; 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))
+ 0))
+
+;; (message-header (NAME VALUE))
+; Translate header into its marshalling data. The name is mapped to
+; its header code and associated value type. This gets translated into
+; the marshalling data form of (code (type value))
+(define (message-header HDR)
+ (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)"
+ (list (char "l")
+ (message-type-code TYPE)
+ (message-flags FLAGS)
+ (PROTOCOL-VERSION 0) ; Major version code
+ (length BODY)
+ (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")
+ DBus (DbusInterface "org.freedesktop.DBus")
+ APPNAME (if (:invoke ROOT (:m DBus "Hello()"))
+ ($it -1 -1 -1))
+ )
+
+;; Installation of some framework notification handlers
+
+;; Helper method to notify
+(define (signal-trace ARGS)
+ (die nil "** Got:" KEY ARGS ))
+
+(: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)
+
+;; Set up the Dbus event loop as prompt-event handler
+(prompt-event Dbus:main-loop)
+
+;;######################################################################
+;;
+;; 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'"
+
+"lsp-dbus.lsp"
--- /dev/null
+;; This newlisp module implements dbus socket connection
+;;
+
+; Require the FOOP context
+(unless (context? MAIN:FOOP) (load "foop.lsp"))
+
+(context 'MAIN:DbusConnection)
+(FOOP path socket name serial)
+
+(define (DbusConnection:DbusConnection PATH)
+ (list (context) PATH -1 nil 0))
+
+;; Increment the serial and return it.
+(define (serial++)
+ (!serial (+ 1 (%serial))))
+
+;; (open-socket)
+; Internal utility method to re-open the %path socket and set the
+; %socket field.
+(define (open-socket)
+ (when (>= (%socket))
+ (close (%socket))
+ (!socket -1))
+ (!socket (net-connect (%path))))
+
+;** Commands from client to server
+; AUTH [mechanism] [initial-response]
+; CANCEL
+; BEGIN
+; DATA <data in hex encoding>
+; ERROR [human-readable error explanation]
+; NEGOTIATE_UNIX_FD
+
+;** Commands from server to client
+; REJECTED <space-separated list of mechanism names>
+; OK <GUID in hex>
+; DATA <data in hex encoding>
+; ERROR [human-readable error explanation]
+; AGREE_UNIX_FD
+
+(define (read-message)
+ (let ((BUFFER "") (RESULT ""))
+ (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)
+; Perform a socket handshake sending MSG and return the result, or if
+; PAT not nil, then return (regex PAT RESULT 0),
+(define (handshake MSG PAT)
+ (let ((RESULT ""))
+ (net-send (%socket) MSG)
+ (setf RESULT (read-message))
+ (if PAT (regex PAT RESULT 0) RESULT)))
+
+(constant
+ 'AUTHFMT "AUTH EXTERNAL %s\r\n"
+ 'AUTHACK "OK (\\S+)\r\n"
+ 'KEEPFMT "NEGOTIATE_UNIX_FD\r\n"
+ 'KEEPACK "AGREE_UNIX_FD\r\n"
+ )
+
+;; (initialize USER)
+; Perform socket initialization sequence and return the name, or nil.
+(define (initialize (USER (env "USER")))
+ (when (and (>= (open-socket))
+ (net-send (%socket) (char 0))
+ (handshake (format AUTHFMT (char2hex USER)) AUTHACK)
+ (!name $1)
+ (handshake KEEPFMT KEEPACK))
+ (handshake "BEGIN\r\n")
+ (%name)))
+
+(define (cancel)
+ (handshake "CANCEL\r\n" "(.*)"))
+
+"lsp-dbus-connection.lsp"
--- /dev/null
+;; This newlisp module implements dbus socket send-receive together
+;; 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()"
+;;
+
+;; 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))
+
+;; This is the list of Dbus messages still to handle.
+(setf pending '())
+
+(define (no-handler KEY MSG)
+ (write-line 2 (format "** No handler %s for:\n%s" KEY (string MSG))))
+
+(define (process-message MSG)
+ (let ((KEY (message-key MSG)))
+ (if (RECV KEY) ($it (lookup "" MSG))
+ (no-handler KEY 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 S)
+ (let ((FDS (list 0 (:%socket SYSTEM-BUS))) (FD nil))
+ (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: "))
+
+(define (human-msg MSG)
+ (human-bytes (unpack (dup "b" (length MSG)) MSG)))
+
+;; Send message, then keep reading messages until there is a reply
+(define (send-recv-message MSG)
+ ;;(die nil (list 'send-recv-message (human-msg 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"
--- /dev/null
+;; This newlisp "module" implements dbus marshalling
+;
+; The newlisp representation is a simplified form using lists for
+; 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 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)
+ (setf S (replace "{" (replace "}" (copy S) ")") "("))
+ (let ((STACK '()) (CUR '()) (A 0))
+ (dolist (X (explode S))
+ (case X
+ (")" (setf X CUR) (setf CUR (pop STACK)))
+ ("(" (push CUR STACK) (setf CUR '()))
+ (true true))
+ (when (and (!= X "a") (!= X "("))
+ (while (and CUR (= "a" (last CUR)))
+ (setf X (list (last CUR) X))
+ (setf CUR (chop CUR))))
+ (when (!= "(" X)
+ (push X CUR -1)))
+ (if (null? CUR) '() CUR)))
+
+;; 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))))
+ (setf DATA (extend PAD DATA))
+ (inc AT (length DATA))
+ DATA))
+
+;; 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
+;; variant elements).
+(constant
+ 'FMTMAP ; mapping dbus type code to byte size and newlisp code
+ '( ("y" 1 "b") ; BYTE (unsigned 8-bit integer)
+ ("b" 4 "lu") ; BOOLEAN (0 is FALSE, 1 is TRUE, else invalid)
+ ("n" 2 "d") ; INT16 (signed 16-bit integer)
+ ("q" 2 "u") ; UINT16 (unsigned 16-bit integer)
+ ("i" 4 "ld") ; INT32 (signed 32-bit integer)
+ ("u" 4 "lu") ; UINT32 (unsigned 32-bit integer)
+ ("x" 8 "Ld") ; INT64 (signed 64-bit integer)
+ ("t" 8 "Lu") ; UINT64 (unsigned 64-bit integer)
+ ("d" 8 "lf") ; DOUBLE (64-bit float)
+ ("h" 4 "lu") ; UINT32 (unix file descriptor)
+ ("a" ? ?) ; ARRAY = UINT32 byte-length, items
+ ("s" ? ?) ; STRING = length + data + NUL
+ ("o" ? ?) ; OBJECT_PATH = BYTE length + data + NUL
+ ("g" ? ?) ; SIGNATURE = BYTE length + data + NUL
+ ("(" ? ?) ; STRUCT begin in signature = (8-align) + data
+ (")" 0 ?) ; STRUCT end in signature
+ ("v" ? ?) ; VARIANT = signature + data
+ ("{" ? ?) ; DICT_ENTRY begin
+ ("}" ? ?) ; DICT_ENTRY end
+ ("r" ? ?) ; reserved STRUCT in bindings?
+ ("e" ? ?) ; reserved DICT_ENTRY in bindings ?
+ ("m" ? ?) ; reserved 'maybe'
+ ("*" ? ?) ; reserved 'single complete type'
+ ("?" ? ?) ; reserved 'basic type'
+ ("@" ? ?) ; reserved
+ ("&" ? ?) ; reserved
+ ("^" ? ?) ; reserved
+ )
+ )
+
+(define (pack-data-item ES DATA)
+ (if (list? ES) (pack-data-struct 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)
+ (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) 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)
+ (let ((PAD (pack-align "" 4))
+ (X (inc AT 4)) ; start index of array bytes
+ (DATA (apply extend (map (curry pack-data-item ES) DATA))))
+ (extend PAD (pack "lu" (- AT X)) DATA)))
+
+;; Pack a struct. ES and DATA elements marshalled pairwise in order
+;; following an initial8-byte alignment.
+(define (pack-data-struct ES 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)
+ ##(println (list 'unpack-align I FMT AT (length DATA)))
+ (align-AT I)
+ (prog1 ((unpack FMT (AT DATA)) 0) (inc AT I)))
+
+;; 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)
+ (unpack-data-item ((expand-signature (unpack-data-signature "g")) 0)))
+
+;; 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 (length DATA)))
+ (if (list? ES) (unpack-data-struct 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, followed by the array
+;; elements.
+(define (unpack-data-array ES)
+ (let ((A AT) (N (+ (unpack-align 4 "u") AT)) (OUT '()))
+ (when (and (list? ES) (!= "a" (ES 0))) (align-AT 8))
+ (while (< AT N)
+ ##(println "---next " (list AT N))
+ (push (unpack-data-item ES) OUT -1))
+ OUT))
+
+;; Unpack a structure or array with ES fields.
+(define (unpack-data-struct ES)
+ ##(println (list 'unpack-data-struct ES AT))
+ (if (= "a" (ES 0)) (unpack-data-array (ES 1))
+ (begin (align-AT 8) (map unpack-data-item ES))))
+
+;; Unpack from a DATA string according to signature SIGN This returns
+;; a pair (unpacked pos) of unpacked data and how much data is
+;; consumed.
+(define (unpack-data SIGN DATA (AT 0))
+ ##(println (format "*** unpack-data %s %d %d" SIGN (length DATA) AT))
+ (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 7) (length DATA))
+ (setf M (unpack-data "yyyyuua(yv)" DATA AT)))
+ (setf AT (M 1))
+ ##(println "message head " (M 0))
+ ##(println (list 'remains AT (length DATA)))
+ (setf M (M 0 -1)) ; Drop all but the headers then map to symbol keys
+ (dotimes (i (length M))
+ (setf (M i 0) (MESSAGE-HEADERS (M i 0) 0)))
+ ##(println "mapped headers " M)
+ ;; Add the body, if any, keyed by "".
+ (setf S (if (lookup 'SIGNATURE M) $it ""))
+ ##(println (list 'sign S))
+ (when (and (!= S "") (setf D (unpack-data S DATA AT)))
+ (setf AT (D 1))
+ (extend M (list (list "" (D 0)))))
+ ;; Collate message and move to the next portion in DATA
+ (push M OUT -1)
+ ##(println (list 'ending AT (length DATA)))
+ ;;(align-AT 4)
+ ##(println (list 'aligned AT (length DATA)))
+ (setf DATA (AT DATA))
+ (setf AT 0)
+ )
+ OUT ))
+
+"lsp-dbus-marshal.lsp"
--- /dev/null
+= lsp-dbus.a(8)
+:doctype: manpage
+:revdate: {sys:date "+%Y-%m-%d %H:%M:%S"}
+:BC: *:*
+
+== NAME
+
+lsp-dbus.a - Dbus API for newlisp.
+
+== SYNOPSIS
+
+.With packnl
+packnl _main.lsp_ *-A lsp-misc.a* *-A lsp-dbus.a*
+
+
+.With incore.lsp
+(load "incore.lsp") +
+(archive "lsp-misc.a") +
+(archive "lsp-utils.a") +
+(load "lsp-dbus.lsp")
+
+== DESCRIPTION
+
+*lsp-dbus.a* implements a newlisp API for Dbus. The module includes a
+context _DbusConnection_ that implements the connection/authorization
+level and a context _Dbus_ that implements the "object
+modelling"/messaging level.
+
+The source software is divided into a couple of different source files
+that are packed together into an _ar_ archive.
+
+Note that *lsp-dbus.a* depends on _FOOP_ and _prog1_ from *lsp-misc.a*.
+
+=== lsp-dbus API
+
+(*load* "lsp-dbus.lsp")::
+
+The main file, *lsp-dbus.lsp*, includes connection setup (see
+*:initialize* below) and client registration (i.e. issuing the dbus
+"Hello():s" message as part of its loading. Currently it connects on
+the system bus (only). It also installs the funcion _main-loop_ as
+_prompt-event_ function for processing any unsolicited messages from
+dbus (so called "signals").
+
+==== The Dbus Context
+
+(*Dbus* _PATH_ [_DESTINATION_])::
+
+The _Dbus_ context is used for identifying remote "objects" with the
+given _PATH_ and _DESTINATION_ (aka bus name). The resulting _FOOP_
+object provides a proxying channel for invoking methods targeting the
+given path on the given bus-name application. When omitted, the
+_DESTINATION_ string is obtained from the _PATH_ string following the
+convention of chopping the initial "/" and replacing remaining "/"
+with ".".
++
+====
+Note that a term like _(Dbus "/org/freedesktop/DBus")_ defines an
+identifer for, or pointer to, a remote "dbus object", and it is here
+referred to as _PROXY_. The _PATH_ part serves as the object
+identifier for dbus while the _DESTINATION_ part is an identfier for
+the application that we expect holds the actual "dbus object" for the
+given _PATH_. This particular term identifies object path
+"/org/freedesktop/DBus" held by the application named
+"org.freedesktop.DBus", which belongs to the dbus framewok.
+
+There is however no central arbitration for paths in dbus. It all
+relies on application developers documenting which paths their
+applications service and access, and then client applications rely on
+using the destination tags for directing their messages to the
+intended applications.
+====
+
+(*:new-path* _PROXY_ _PATH_)::
+
+The _:new-path_ method clones the FOOP object to dentify the given
+_PATH_ for the same destination.
+
+(*:invoke* _PROXY_ _METHOD_ _ARGUMENTS_ _FLAGS_)::
+
+The _:invoke_ method performs a Dbus _METHOD_CALL_ handshake for the
+gven _PROXY_ using the given _METHOD_, _ARGUMENTS_ and message
+_FLAGS_. The function sends a dbus message and then polls for debus
+messages until the reply message has arrived. any and all other
+messages recevied meanwhile are added to the _pending_ list.
++
+The _METHOD_ is given as a string composed as path, interface, name
+and signature
++
+====
+_path:interface.name(signature)_
+====
++
+The _path:_ component including the colon is optional and taken from
+the _PROXY_ by default. The _interface._ component incuding the period
+is also optional as per dbus documentation: a method call without
+explicit interface results in that the method name is looked up across
+all interfaces of the destination path.
++
+The _SIGNATURE_ is the dbus style signature as a character sequence,
+where y, b, n, q, i, u, x, t, d and h indicate the basic types BYTE,
+BOOLEAN, INT16, UINT16, INT32, UINT32, INT64, UINT64, DOUBLE and FD
+respectivly (both BOOLEAN and FD are also UINT32); a indicates
+"array"; s, o and g indicate strings of various restrictions;
+parentheses and curly braces wrap "struct" signatures, and v indicates
+a pair of a data item preceded by its signature. Refer to dbus
+documentation for further details.
++
+The given _ARGUMENTS_ is a list structure that must correspond to the
+given signature. All number and string values are mapped naturally
+into the indicated signatures while arrays, struct and variant
+elements should occur as lists: an array is formed from the list of
+elements, as is a struct. A variant typed element must occur as the
+list of signature and data. See also the MARSHALLING section below.
++
+The optional _FLAGS_ argument is given either a bit mask (number) or a
+list of the _Dbus_ context symbols _NO_REPLY_EXPECTED_,
+_NO_AUTO_START_ and _ALLOW_INTERACTIVE_AUTHORIZATION_. Each of these
+correspond to a bit position in the _FLAGS_ mask and they are combined
+with bit-OR. Refer to dbus documentation for further details.
++
+.Some :invoke usage examples
+----
+(:invoke Dbus:ROOT "RequestName(su)" '("my.client" 0))
+
+(:invoke Dbus:ROOT "GetNameOwner(s)" '("org.bluez" 0))
+
+(setf BT (Dbus "/" "org.bluez"))
+(:invoke BT "GetManagedObjects()")
+(Dbus:process-pending)
+----
++
+Note "org.bluez" here provides the "GetManagedObjects()" method of
+interface "org.freedesktop.ObjectManager" unambiguously on the root
+path, "/", rather than its bus name path "/org/bluez".
++
+While this process is waiting for the _METHOD_CALL_ reply it may
+receive signal messsages from _dbus_. These will be added to the list
+of "pending callbacks" that is processed via the _process-all-pending_
+function, either via an explicit call following the handshake or
+"automagically" as part of the _main-loop_ function that gets
+installed as as _prompt-event_ function.
++
+.Return value:
+[caption=""]
+====
+The return value of *:invoke* is the METHOD_REPLY message reduced into
+an association list of the headers (with the _Dbus_ header symbols as
+keys) extended with the method return value as a list wrapped into a
+final association that is keyed by the empty string.
+
+In other words, the template for using *:invoke* may look like the
+following:
+----
+(if (:invoke ...) ($it -1 -1 -1))
+----
+====
+
+(*Dbus:process-all-pending*)::
+
+The _process-all-pending_ function processes all pending signal
+messages by invoking their associated handler functions.
+
+(*prompt-event Dbus:main-loop*)::
+
+The _main-loop_ function is set up as _prompt-event_ function for a
+combined _net-select_ on both stdin and the dbus socket as well as to
+process all pending signal messages. Any input from dbus, which are
+signal messages, are added to the pending list, which also is
+processed one message at a time until empty.
++
+Note that newlisp uses readline for input but that this is not
+activated in _main-loop_. Therefore line editing is not available
+immediately. However the operator may use ^D to leave the main-loop
+and enter the "normal" command line input state for a single line
+input (with line editing), or an initial newline for multi-line input
+that is "submitted" by means of two newlines.
+
+(*:handler* _OBJ_ _KEY_ _HANDLER_)::
+
+This function registers a handler callback for a key that is a string
+composed as "path:interface.member(signature)". The handler function
+takes a single argument, which is the list of unmarshalled actual call
+arguments.
+
+==== The DbusConnection Context
+
+(*DbusConnection* _PATH)::
+
+The _DbusConnection_ context is a FOOP implementation intended for the
+dbus socket connection. Each _(DbusConnection PATH)_ is intended to be
+like a real object that contains state, namely the opened socket file
+descriptor, the connection name given to it by DBus on connection and
+and the messaging serial.
+
+(*:serial++* _OBJECT_)::
+
+This method increments the serial of the given object.
+
+(*:open-socket* _OBJECT_)::
+
+This method opens the path and assignes the socket file descriptor of
+the given object. Before that though, if the socket file descriptor is
+non-negative then that file descriptor is closed before opening the
+object's path.
+
+(*:read-message* _OBJECT_)::
+
+This method reads the next message by reading data from the socket
+successively while there's something to read within a millisecond.
+
+(*:handshake* _OBJECT_ _MESSAGE_ [_PATTERN_])::
+
+This method performs a "raw" text-based handshake on the connection,
+which means to send the given message and then read and return the
+response message. If a _PATTERN_ is given, then the response must
+match the pattern (assigning the automatic variables $1 etc according
+to the pattern). The method returns nil if the given pattern is not
+matched. Note that this method is used only during connection setup
+and dbus communication uses its own marshalling subsequently.
+
+(*:initialize* _OBJECT_ [_USER_])::
+
+This method performs the connection set up including the very first
+newline and the subsequent AUTH handshake. It ends with the connection
+in "BEGIN" mode and returns the received connection name.
+
+=== MARSHALLING
+
+dbus documentation uses the terms "marshalling" and "unmarshalling"
+for the translations of data from/to program data to/from dbus message
+bytes. The data in newlisp mapped straight-forwardly with the special
+note that both "struct" and "array" are held as lists in newlisp. To
+that end, the data for the variant type signature must be wrapped into
+an extra list of the format _(signature value)_ with explcit dbus
+signature string. However, such wrapping does not take place upon
+unmarshalling.
+
+
+== SEE ALSO
+
+*newlisp*, *packnl*, *incore.lsp*
+
+== AUTHOR
+
+Ralph Ronnquist <ralph.ronnquist@gmail.com>
projects / rrq / newlisp / dbus-api.git / commitdiff