lsp-dbus-events.lsp

   1 ;; This newlisp module implements dbus socket send-receive together
   2 ;; with signal receive. (This file should be loaded into the Dbus
   3 ;; context)
   4 ;;
   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.
   8 ;;
   9 ;; Stdin is handled with priority.
  10 ;;
  11 ;; Dbus messages are read and added to the pending list.
  12 ;;
  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:
  16 ;;
  17 ;;    "/org/freedesktop/DBus:org.freedesktop.DBus.NameAcquired(s)"
  18 ;;
  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
  24 ;;
  25 ;;    "/org/freedesktop/DBus:org.freedesktop.DBus.Hello()"
  26 ;;
  27
  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) ")" ))
  32
  33 ;; This is the table of handlers, keyed by path:interface:method:signature
  34 (define RECV:RECV nil)
  35
  36 ;; Utility function to install a handler for a given key,
  37 (define (handler KEY HANDLER)
  38   (RECV (string (%path) ":" KEY) HANDLER))
  39
  40 ;; This is the list of Dbus messages still to handle.
  41 (setf pending '())
  42
  43 (define (no-handler KEY MSG)
  44   (write-line 2 (format "** No handler %s for:\n%s" KEY (string MSG))))
  45
  46 (define (process-message MSG)
  47   (let ((KEY (message-key MSG)))
  48     (if (RECV KEY) ($it (lookup "" MSG))
  49       (no-handler KEY MSG))))
  50
  51 ;; Process all messages currently pending
  52 (define (process-all-pending)
  53   (while (if (pop pending) (process-message $it))))
  54
  55 ;; The main-loop is intended as a prompt-handler so as to deal with
  56 ;; asyncronous events
  57 (define (main-loop S)
  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) ""))
  63             (extend pending $it))
  64         ))
  65     "main-loop: "))
  66
  67 (define (human-msg MSG)
  68   (human-bytes (unpack (dup "b" (length MSG)) MSG)))
  69
  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)
  74   (let ((REPLY nil))
  75     (while (nil? REPLY)
  76       (dolist (M (unpack-messages (:read-message SYSTEM-BUS)))
  77         (if (lookup 'REPLY_SERIAL M) (setf REPLY M)
  78           (push M pending -1))))
  79     REPLY))
  80
  81 "lsp-dbus-events.lsp"