1 ;; This newlisp module implements dbus socket send-receive together
2 ;; with signal receive. (This file should be loaded into the Dbus
5 ;; The REPL loop is re-mastered by means of a prompt-event function
6 ;; that firstly handles any pending dbus messages, and secondly
7 ;; net-select on both the dbus socket and stdin.
9 ;; Stdin is handled with priority.
11 ;; Dbus messages are read and added to the pending list.
13 ;; Handlers are set up as functions (fn (data msg) ..) identified by
14 ;; "dbus callback key" consisting of path, interface, method and
15 ;; signature separated by ":". For example:
17 ;; "/org/freedesktop/DBus:org.freedesktop.DBus.NameAcquired(s)"
19 ;; would identify the handler for the NameAcquired(string) method of
20 ;; the interface "org.freedesktop.DBus" of the path
21 ;; "/org/freedesktop/DBus" of the client. That particular callback is
22 ;; a s.c. signal sent by the dbus framework implementation in reaction
23 ;; to the initial Hello call, i.e. the s.c. invocation of
25 ;; "/org/freedesktop/DBus:org.freedesktop.DBus.Hello()"
28 ;; Return the callback key for a message MSG
29 (define (message-key MSG)
30 (string (lookup 'PATH MSG) ":" (lookup 'INTERFACE MSG) "."
31 (lookup 'MEMBER MSG) "(" (lookup 'SIGNATURE MSG) ")" ))
33 ;; This is the table of handlers, keyed by path:interface:method:signature
34 (define RECV:RECV nil)
36 ;; Utility function to install a handler for a given key,
37 (define (handler KEY HANDLER)
38 (RECV (string (%path) ":" KEY) HANDLER))
40 ;; This is the list of Dbus messages still to handle.
43 (define (no-handler KEY MSG)
44 (write-line 2 (format "** No handler %s for:\n%s" KEY (string MSG))))
46 (define (process-message MSG)
47 (let ((KEY (message-key MSG)))
48 (if (RECV KEY) ($it (lookup "" MSG))
49 (no-handler KEY MSG))))
51 ;; Process all messages currently pending
52 (define (process-all-pending)
53 (while (if (pop pending) (process-message $it))))
55 ;; The main-loop is intended as a prompt-handler so as to deal with
58 (let ((FDS (list 0 (:%socket SYSTEM-BUS))) (FD nil))
59 (write 2 (string "> "))
60 (while (or pending (not (member 0 (net-select FDS "r" -1))))
61 (if (pop pending) (process-message $it)
62 (if (unpack-messages (or (:read-message SYSTEM-BUS) ""))
67 (define (human-msg MSG)
68 (human-bytes (unpack (dup "b" (length MSG)) MSG)))
70 ;; Send message, then keep reading messages until there is a reply
71 (define (send-recv-message MSG)
72 ;;(die nil (list 'send-recv-message (human-msg MSG)))
73 (net-send (:%socket SYSTEM-BUS) MSG)
76 (dolist (M (unpack-messages (:read-message SYSTEM-BUS)))
77 (if (lookup 'REPLY_SERIAL M) (setf REPLY M)
78 (push M pending -1))))