--- /dev/null
+
+LSPLIB = -A lsp-util/lsp-util.a -A lsp-dbus/lsp-dbus.a
+
+LSPSRC = lsp-dbus-test.lsp
+
+test0: ${LSPSRC}
+ ${HOME}/src/borta/packnl/packnl -w $@ $^ ${LSPLIB}
--- /dev/null
+#!/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")))
+
+(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 ))
+
+(setf M (:invoke ROOT "Hello" "org.freedesktop.DBus"))
+(println (unpack-messages M))
+
+"lsp-dbus-test.lsp"
--- /dev/null
+# Create the newlisp library dbus.lsplib
+
+LSPSRC = lsp-dbus-connection.lsp lsp-dbus.lsp lsp-dbus-marshal.lsp
+LSPSRC += lsp-dbus-events.lsp
+
+lsp-dbus.a: ${LSPSRC}
+ ar r $@ $^
+
+
--- /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 (net-select (%socket) "r" 1000)
+ (net-receive (%socket) BUFFER 8192)
+ (extend RESULT BUFFER))
+ 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)))
+
+(define (char2hex STR)
+ (join (map (curry format "%2x") (map char (explode STR)))))
+
+(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" "(.*)"))
+
+"DbusConnection"
+
--- /dev/null
+;; This newlisp module implements dbus socket send-receive together
+;; with signal receive.
+;
+; This should be included into the Dbus contect
+
+(setf pending '())
+
+(define 'RECV:RECV nil) ; Table of objects that receive calls/signals
+
+(define (set-object PATH HANDLER) (RECV PATH HANDLER))
+
+(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 (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)
+
+;; 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
--- /dev/null
+;; This newlisp "module" implements dbus marshalling
+;
+; The newlisp representation is a simplified form using lists for
+; structs and arrays
+
+;;================
+; 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.
+;
+; 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 '()))
+ (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) '() (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)))
+
+;; Align AT to an I multiple by adding nul bytes, then extend it with
+;; DATA, and increment AT
+(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 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" 1 "b") ; 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)
+ ;;(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 "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)))
+
+(define (pack-data-string ES DATA)
+ (pack-align (pack (format "lus%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))))
+ (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)
+ ;;(println (list 'pack-data-struct AT 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
+
+(define (align-AT I)
+ (inc AT (% (- I (% AT I)) I)))
+
+(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)))))
+
+(define (unpack-data-variant)
+ ;;(println (unpack "bbbb" (AT DATA)))
+ (let ((ES (char ((unpack "bbb" (AT DATA)) 1))))
+ (inc AT 3)
+ (unpack-data-item ES)))
+
+;; Unpack the ES item from (AT DATA) and increment AT
+(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 "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
+(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))
+
+;; Unpack a structure or array with ES fields.
+(define (unpack-data-struct ES)
+ (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 (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))
+
--- /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/
+;;
+
+(unless (context? MAIN:FOOP) (load "foop.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.
+(define (Dbus:Dbus PATH (BUS 'SYSTEM-BUS))
+ (list (context) PATH BUS))
+
+;; Return the bus name
+(define (bus-name)
+ (join (find-all "([^/]+)" (%path) $1 0) "."))
+
+;; Return the DbusConnection connection adapter
+(define (connection)
+ (eval (%bus)))
+
+;; ====================
+;; Dbus messages
+
+(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")
+ )
+ )
+
+;; Determine the type code = index of teh type symbol in the
+;; MESSAGE-TYPES list.
+(define (message-type-code TYPE)
+ (or (find TYPE MESSAGE-TYPES =) 0))
+
+(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.
+(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)
+ (let ((CODE (find (list (HDR 0) '*) MESSAGE-HEADERS match) 0))
+ (list CODE (list (MESSAGE-HEADERS CODE 1) (HDR 1)))))
+
+;; Return a marshalled message
+(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)
+ (: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
+ ))
+
+"lsp-dbus.lsp"
--- /dev/null
+# Create the newlisp library foop.lsplib
+
+LSPSRC = foop.lsp misc.lsp
+
+lsp-util.a: ${LSPSRC}
+ ar r $@ $^
--- /dev/null
+;; This newlisp module provides FOOP modelling support
+;;
+;; Functional Object-Oriented Programming (FOOP) is an abstraction
+;; overlay using the newlisp context notion as similar to the class
+;; notion in genuine object-oriented programming languages. This is
+;; set out in newlisp by means of the representation principle that an
+;; instance of a FOOP "class" (i.e. context) is a list headed by the
+;; context itself, and followed by the "member values".
+;;
+;; FOOP further includes by the "method invocation" syntax where a
+;; function is preceded by ':' and then followed by the instance
+;; concerned before actual function arguments. That instance is then
+;; stoved away as implicitly available via the (self) function, and
+;; the member values accessible via index, e.g. the term (self 3)
+;; refers to the third member of the instance. The self references are
+;; destructively assignable with setf.
+;;
+;; This modelling support adds member name declaration together with
+;; automatic getter and setter defintions. The (FOOP ...) term is used
+;; for declaring member names in order. For example:
+;;
+;; (context 'MAIN:EX")
+;; (FOOP a b c)
+;; (define (EX:EX n) (list (context) (+ n 4) 3 2))
+;;
+;; That would declare a FOOP context EX with instances having three
+;; members named a, b and c. The declaratin results in a variable EX:.
+;; whose value is (FOOP a b c), as well as three access functions for
+;; each member: the member position index (.member), a getter
+;; (%member) and a setter (!member V).
+;;
+;; As indicated in the example, (FOOP a b c) does not define the
+;; "constructor". It only defines the access functions.
+
+(context 'FOOP)
+
+;; Helper function to make a new symbol for the context of S by
+;; preceeding it with string P.
+(define (name P S) (sym (string P (term S)) (prefix S)))
+
+;; (FOOP name ...)
+; foop is a language extension to declare the field names of a FOOP
+; object type, and thereby gain getter and setter functions with the
+; naming formats (:%name obj) and (:!name obj value) respectively .
+(define-macro (FOOP:FOOP)
+ (let ((K (sym "." (prefix (first (args)))))
+ (V (cons (context) (args)))
+ (I 0))
+ (set K V)
+ (dolist (S (args))
+ (letex ((GET (name "%" S))
+ (SET (name "!" S))
+ (IT (name "." S))
+ (V (sym "V" (prefix S)))
+ (I (inc I)))
+ (define (IT) I)
+ (define (GET) (self I))
+ (define (SET V) (setf (self I) V))))
+ ))
+
+"foop.lsp"
--- /dev/null
+(define (prog1 X) X)
+(global 'prog1)
+
+(define (die N)
+ (when (args) (write-line 2 (join (map string (args)) " ")))
+ (exit N))
+(global 'die)
+
+;; Print binary byte as octal or as ASCII character [32-126]
+(define (octal-byte x)
+ (if (and (> x 31) (< x 127)) (char x) (format "\\%o" x)))
+
+;; Print string as binary octals
+(define (octals-string S)
+ (join (map octal-byte (unpack (dup "b" (length S)) S))) "")
+(global 'octals-string 'octal-byte)
projects / rrq / lsp-utils.git / commitdiff