misc/fuel/fuel-connection.el

   1 ;;; fuel-connection.el -- asynchronous comms with the fuel listener
   2
   3 ;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
   4 ;; See http://factorcode.org/license.txt for BSD license.
   5
   6 ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
   7 ;; Keywords: languages, fuel, factor
   8 ;; Start date: Thu Dec 11, 2008 03:10
   9
  10 ;;; Comentary:
  11
  12 ;; Handling communications via a comint buffer running a factor
  13 ;; listener.
  14
  15 ;;; Code:
  16
  17 \f
  18 ;;; Default connection:
  19
  20 (make-variable-buffer-local
  21  (defvar fuel-con--connection nil))
  22
  23 (defun fuel-con--get-connection (buffer/proc)
  24   (if (processp buffer/proc)
  25       (fuel-con--get-connection (process-buffer buffer/proc))
  26     (with-current-buffer buffer/proc
  27       (or fuel-con--connection
  28           (setq fuel-con--connection
  29                 (fuel-con--setup-connection buffer/proc))))))
  30
  31 \f
  32 ;;; Request and connection datatypes:
  33
  34 (defun fuel-con--connection-queue-request (c r)
  35   (let ((reqs (assoc :requests c)))
  36     (setcdr reqs (append (cdr reqs) (list r)))))
  37
  38 (defun fuel-con--make-request (str cont &optional sender-buffer)
  39   (list :fuel-connection-request
  40         (cons :id (random))
  41         (cons :string str)
  42         (cons :continuation cont)
  43         (cons :buffer (or sender-buffer (current-buffer)))
  44         (cons :output "")))
  45
  46 (defsubst fuel-con--request-p (req)
  47   (and (listp req) (eq (car req) :fuel-connection-request)))
  48
  49 (defsubst fuel-con--request-id (req)
  50   (cdr (assoc :id req)))
  51
  52 (defsubst fuel-con--request-string (req)
  53   (cdr (assoc :string req)))
  54
  55 (defsubst fuel-con--request-continuation (req)
  56   (cdr (assoc :continuation req)))
  57
  58 (defsubst fuel-con--request-buffer (req)
  59   (cdr (assoc :buffer req)))
  60
  61 (defun fuel-con--request-output (req &optional suffix)
  62   (let ((cell (assoc :output req)))
  63     (when suffix (setcdr cell (concat (cdr cell) suffix)))
  64     (cdr cell)))
  65
  66 (defsubst fuel-con--request-deactivate (req)
  67   (setcdr (assoc :continuation req) nil))
  68
  69 (defsubst fuel-con--request-deactivated-p (req)
  70   (null (cdr (assoc :continuation req))))
  71
  72 (defsubst fuel-con--make-connection (buffer)
  73   (list :fuel-connection
  74         (list :requests)
  75         (list :current)
  76         (cons :completed (make-hash-table :weakness 'value))
  77         (cons :buffer buffer)))
  78
  79 (defsubst fuel-con--connection-p (c)
  80   (and (listp c) (eq (car c) :fuel-connection)))
  81
  82 (defsubst fuel-con--connection-requests (c)
  83   (cdr (assoc :requests c)))
  84
  85 (defsubst fuel-con--connection-current-request (c)
  86   (cdr (assoc :current c)))
  87
  88 (defun fuel-con--connection-clean-current-request (c)
  89   (let* ((cell (assoc :current c))
  90          (req (cdr cell)))
  91     (when req
  92       (puthash (fuel-con--request-id req) req (cdr (assoc :completed c)))
  93       (setcdr cell nil))))
  94
  95 (defsubst fuel-con--connection-completed-p (c id)
  96   (gethash id (cdr (assoc :completed c))))
  97
  98 (defsubst fuel-con--connection-buffer (c)
  99   (cdr (assoc :buffer c)))
 100
 101 (defun fuel-con--connection-pop-request (c)
 102   (let ((reqs (assoc :requests c))
 103         (current (assoc :current c)))
 104     (setcdr current (prog1 (cadr reqs) (setcdr reqs (cddr reqs))))
 105     (if (and (cdr current)
 106              (fuel-con--request-deactivated-p (cdr current)))
 107         (fuel-con--connection-pop-request c)
 108       (cdr current))))
 109
 110 \f
 111 ;;; Connection setup:
 112
 113 (defun fuel-con--setup-connection (buffer)
 114   (set-buffer buffer)
 115   (let ((conn (fuel-con--make-connection buffer)))
 116     (fuel-con--setup-comint)
 117     (setq fuel-con--connection conn)))
 118
 119 (defun fuel-con--setup-comint ()
 120   (add-hook 'comint-redirect-filter-functions
 121             'fuel-con--comint-redirect-filter t t)
 122   (add-hook 'comint-redirect-hook
 123             'fuel-con--comint-redirect-hook))
 124
 125 \f
 126 ;;; Logging:
 127
 128 (defvar fuel-con--log-size 32000
 129   "Maximum size of the Factor messages log.")
 130
 131 (defvar fuel-con--log-verbose-p t
 132   "Log level for Factor messages.")
 133
 134 (define-derived-mode factor-messages-mode fundamental-mode "Factor Messages"
 135   "Simple mode to log interactions with the factor listener"
 136   (kill-all-local-variables)
 137   (buffer-disable-undo)
 138   (set (make-local-variable 'comint-redirect-subvert-readonly) t)
 139   (add-hook 'after-change-functions
 140             '(lambda (b e len)
 141                (let ((inhibit-read-only t))
 142                  (when (> b fuel-con--log-size)
 143                    (delete-region (point-min) b))))
 144             nil t)
 145   (setq buffer-read-only t))
 146
 147 (defun fuel-con--log-buffer ()
 148   (or (get-buffer "*factor messages*")
 149       (save-current-buffer
 150         (set-buffer (get-buffer-create "*factor messages*"))
 151         (factor-messages-mode)
 152         (current-buffer))))
 153
 154 (defun fuel-con--log-msg (type &rest args)
 155   (with-current-buffer (fuel-con--log-buffer)
 156     (let ((inhibit-read-only t))
 157       (insert (format "\n%s: %s\n" type (apply 'format args))))))
 158
 159 (defsubst fuel-con--log-warn (&rest args)
 160   (apply 'fuel-con--log-msg 'WARNING args))
 161
 162 (defsubst fuel-con--log-error (&rest args)
 163   (apply 'fuel-con--log-msg 'ERROR args))
 164
 165 (defsubst fuel-con--log-info (&rest args)
 166   (if fuel-con--log-verbose-p (apply 'fuel-con--log-msg 'INFO args) ""))
 167
 168 \f
 169 ;;; Requests handling:
 170
 171 (defun fuel-con--process-next (con)
 172   (when (not (fuel-con--connection-current-request con))
 173     (let* ((buffer (fuel-con--connection-buffer con))
 174            (req (fuel-con--connection-pop-request con))
 175            (str (and req (fuel-con--request-string req))))
 176       (when (and buffer req str)
 177         (set-buffer buffer)
 178         (when fuel-con--log-verbose-p
 179           (with-current-buffer (fuel-con--log-buffer)
 180             (let ((inhibit-read-only t))
 181               (fuel-con--log-info "<%s>: %s" (fuel-con--request-id req) str))))
 182         (comint-redirect-send-command str (fuel-con--log-buffer) nil t)))))
 183
 184 (defun fuel-con--process-completed-request (req)
 185   (let ((str (fuel-con--request-output req))
 186         (cont (fuel-con--request-continuation req))
 187         (id (fuel-con--request-id req))
 188         (rstr (fuel-con--request-string req))
 189         (buffer (fuel-con--request-buffer req)))
 190     (if (not cont)
 191         (fuel-con--log-warn "<%s> Droping result for request %S (%s)"
 192                             id rstr str)
 193       (condition-case cerr
 194           (with-current-buffer (or buffer (current-buffer))
 195             (funcall cont str)
 196             (fuel-con--log-info "<%s>: processed\n\t%s" id str))
 197         (error (fuel-con--log-error "<%s>: continuation failed %S \n\t%s"
 198                                     id rstr cerr))))))
 199
 200 (defun fuel-con--comint-redirect-filter (str)
 201   (if (not fuel-con--connection)
 202       (fuel-con--log-error "No connection in buffer (%s)" str)
 203     (let ((req (fuel-con--connection-current-request fuel-con--connection)))
 204       (if (not req) (fuel-con--log-error "No current request (%s)" str)
 205         (fuel-con--request-output req str)
 206         (fuel-con--log-info "<%s>: in progress" (fuel-con--request-id req)))))
 207   ".\n")
 208
 209 (defun fuel-con--comint-redirect-hook ()
 210   (if (not fuel-con--connection)
 211       (fuel-con--log-error "No connection in buffer")
 212     (let ((req (fuel-con--connection-current-request fuel-con--connection)))
 213       (if (not req) (fuel-con--log-error "No current request (%s)" str)
 214         (fuel-con--process-completed-request req)
 215         (fuel-con--connection-clean-current-request fuel-con--connection)))))
 216
 217 \f
 218 ;;; Message sending interface:
 219
 220 (defun fuel-con--send-string (buffer/proc str cont &optional sender-buffer)
 221   (save-current-buffer
 222     (let ((con (fuel-con--get-connection buffer/proc)))
 223       (unless con
 224         (error "FUEL: couldn't find connection"))
 225       (let ((req (fuel-con--make-request str cont sender-buffer)))
 226         (fuel-con--connection-queue-request con req)
 227         (fuel-con--process-next con)
 228         req))))
 229
 230 (defvar fuel-connection-timeout 30000
 231   "Time limit, in msecs, blocking on synchronous evaluation requests")
 232
 233 (defun fuel-con--send-string/wait (buffer/proc str cont &optional timeout sbuf)
 234   (save-current-buffer
 235     (let* ((con (fuel-con--get-connection buffer/proc))
 236          (req (fuel-con--send-string buffer/proc str cont sbuf))
 237          (id (and req (fuel-con--request-id req)))
 238          (time (or timeout fuel-connection-timeout))
 239          (step 2))
 240       (when id
 241         (while (and (> time 0)
 242                     (not (fuel-con--connection-completed-p con id)))
 243           (sleep-for 0 step)
 244           (setq time (- time step)))
 245         (or (> time 0)
 246             (fuel-con--request-deactivate req)
 247             nil)))))
 248
 249 \f
 250 (provide 'fuel-connection)
 251 ;;; fuel-connection.el ends here