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 (require 'fuel-log)
  18 (require 'fuel-base)
  19
  20 (require 'comint)
  21 (require 'advice)
  22
  23 \f
  24 ;;; Default connection:
  25
  26 (make-variable-buffer-local
  27  (defvar fuel-con--connection nil))
  28
  29 (defun fuel-con--get-connection (buffer/proc)
  30   (if (processp buffer/proc)
  31       (fuel-con--get-connection (process-buffer buffer/proc))
  32     (with-current-buffer buffer/proc
  33       (or fuel-con--connection
  34           (setq fuel-con--connection
  35                 (fuel-con--setup-connection buffer/proc))))))
  36
  37 \f
  38 ;;; Request and connection datatypes:
  39
  40 (defun fuel-con--connection-queue-request (c r)
  41   (let ((reqs (assoc :requests c)))
  42     (setcdr reqs (append (cdr reqs) (list r)))))
  43
  44 (defun fuel-con--make-request (str cont &optional sender-buffer)
  45   (list :fuel-connection-request
  46         (cons :id (random))
  47         (cons :string str)
  48         (cons :continuation cont)
  49         (cons :buffer (or sender-buffer (current-buffer)))))
  50
  51 (defsubst fuel-con--request-p (req)
  52   (and (listp req) (eq (car req) :fuel-connection-request)))
  53
  54 (defsubst fuel-con--request-id (req)
  55   (cdr (assoc :id req)))
  56
  57 (defsubst fuel-con--request-string (req)
  58   (cdr (assoc :string req)))
  59
  60 (defsubst fuel-con--request-continuation (req)
  61   (cdr (assoc :continuation req)))
  62
  63 (defsubst fuel-con--request-buffer (req)
  64   (cdr (assoc :buffer req)))
  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         (cons :requests (list))
  75         (cons :current nil)
  76         (cons :completed (make-hash-table :weakness 'value))
  77         (cons :buffer buffer)
  78         (cons :timer nil)))
  79
  80 (defsubst fuel-con--connection-p (c)
  81   (and (listp c) (eq (car c) :fuel-connection)))
  82
  83 (defsubst fuel-con--connection-requests (c)
  84   (cdr (assoc :requests c)))
  85
  86 (defsubst fuel-con--connection-current-request (c)
  87   (cdr (assoc :current c)))
  88
  89 (defun fuel-con--connection-clean-current-request (c)
  90   (let* ((cell (assoc :current c))
  91          (req (cdr cell)))
  92     (when req
  93       (puthash (fuel-con--request-id req) req (cdr (assoc :completed c)))
  94       (setcdr cell nil))))
  95
  96 (defsubst fuel-con--connection-completed-p (c id)
  97   (gethash id (cdr (assoc :completed c))))
  98
  99 (defsubst fuel-con--connection-buffer (c)
 100   (cdr (assoc :buffer c)))
 101
 102 (defun fuel-con--connection-pop-request (c)
 103   (let ((reqs (assoc :requests c))
 104         (current (assoc :current c)))
 105     (setcdr current (prog1 (cadr reqs) (setcdr reqs (cddr reqs))))
 106     (if (and (cdr current)
 107              (fuel-con--request-deactivated-p (cdr current)))
 108         (fuel-con--connection-pop-request c)
 109       (cdr current))))
 110
 111 (defun fuel-con--connection-start-timer (c)
 112   (let ((cell (assoc :timer c)))
 113     (when (cdr cell) (cancel-timer (cdr cell)))
 114     (setcdr cell (run-at-time t 0.5 'fuel-con--process-next c))))
 115
 116 (defun fuel-con--connection-cancel-timer (c)
 117   (let ((cell (assoc :timer c)))
 118     (when (cdr cell) (cancel-timer (cdr cell)))))
 119
 120 \f
 121 ;;; Connection setup:
 122
 123 (defun fuel-con--cleanup-connection (c)
 124   (fuel-con--connection-cancel-timer c))
 125
 126 (defun fuel-con--setup-connection (buffer)
 127   (set-buffer buffer)
 128   (fuel-con--cleanup-connection fuel-con--connection)
 129   (let ((conn (fuel-con--make-connection buffer)))
 130     (fuel-con--setup-comint)
 131     (prog1
 132         (setq fuel-con--connection conn)
 133       (fuel-con--connection-start-timer conn))))
 134
 135 (defconst fuel-con--prompt-regex "( .+ ) ")
 136 (defconst fuel-con--eot-marker "<~FUEL~>")
 137 (defconst fuel-con--init-stanza "USE: fuel f fuel-eval")
 138
 139 (defconst fuel-con--comint-finished-regex
 140   (format "^%s$" fuel-con--eot-marker))
 141
 142 (defun fuel-con--setup-comint ()
 143   (set (make-local-variable 'comint-redirect-insert-matching-regexp) t)
 144   (add-hook 'comint-redirect-filter-functions
 145             'fuel-con--comint-preoutput-filter nil t)
 146   (add-hook 'comint-redirect-hook
 147             'fuel-con--comint-redirect-hook nil t))
 148
 149 (defadvice comint-redirect-setup (after fuel-con--advice activate)
 150   (setq comint-redirect-finished-regexp fuel-con--comint-finished-regex))
 151
 152 (defun fuel-con--comint-preoutput-filter (str)
 153   (when (string-match fuel-con--comint-finished-regex str)
 154     (setq comint-redirect-finished-regexp fuel-con--prompt-regex))
 155   str)
 156
 157 \f
 158 ;;; Requests handling:
 159
 160 (defsubst fuel-con--comint-buffer ()
 161   (get-buffer-create " *fuel connection retort*"))
 162
 163 (defsubst fuel-con--comint-buffer-form ()
 164   (with-current-buffer (fuel-con--comint-buffer)
 165     (goto-char (point-min))
 166     (condition-case nil
 167         (read (current-buffer))
 168       (error (list 'fuel-con-error (buffer-string))))))
 169
 170 (defun fuel-con--process-next (con)
 171   (when (not (fuel-con--connection-current-request con))
 172     (let* ((buffer (fuel-con--connection-buffer con))
 173            (req (fuel-con--connection-pop-request con))
 174            (str (and req (fuel-con--request-string req)))
 175            (cbuf (with-current-buffer (fuel-con--comint-buffer)
 176                    (erase-buffer)
 177                    (current-buffer))))
 178       (if (not (buffer-live-p buffer))
 179           (fuel-con--connection-cancel-timer con)
 180         (when (and buffer req str)
 181           (set-buffer buffer)
 182           (fuel-log--info "<%s>: %s" (fuel-con--request-id req) str)
 183           (comint-redirect-send-command (format "%s" str) cbuf nil t))))))
 184
 185 (defun fuel-con--process-completed-request (req)
 186   (let ((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-log--warn "<%s> Droping result for request %S (%s)"
 192                             id rstr req)
 193       (condition-case cerr
 194           (with-current-buffer (or buffer (current-buffer))
 195             (funcall cont (fuel-con--comint-buffer-form))
 196             (fuel-log--info "<%s>: processed\n\t%s" id req))
 197         (error (fuel-log--error
 198                 "<%s>: continuation failed %S \n\t%s" id rstr cerr))))))
 199
 200 (defun fuel-con--comint-redirect-hook ()
 201   (if (not fuel-con--connection)
 202       (fuel-log--error "No connection in buffer")
 203     (let ((req (fuel-con--connection-current-request fuel-con--connection)))
 204       (if (not req) (fuel-log--error "No current request")
 205         (fuel-con--process-completed-request req)
 206         (fuel-con--connection-clean-current-request fuel-con--connection)))))
 207
 208 \f
 209 ;;; Message sending interface:
 210
 211 (defun fuel-con--send-string (buffer/proc str cont &optional sender-buffer)
 212   (save-current-buffer
 213     (let ((con (fuel-con--get-connection buffer/proc)))
 214       (unless con
 215         (error "FUEL: couldn't find connection"))
 216       (let ((req (fuel-con--make-request str cont sender-buffer)))
 217         (fuel-con--connection-queue-request con req)
 218         (fuel-con--process-next con)
 219         req))))
 220
 221 (defvar fuel-connection-timeout 30000
 222   "Time limit, in msecs, blocking on synchronous evaluation requests")
 223
 224 (defun fuel-con--send-string/wait (buffer/proc str cont &optional timeout sbuf)
 225   (save-current-buffer
 226     (let* ((con (fuel-con--get-connection buffer/proc))
 227            (req (fuel-con--send-string buffer/proc str cont sbuf))
 228            (id (and req (fuel-con--request-id req)))
 229            (time (or timeout fuel-connection-timeout))
 230            (step 100)
 231            (waitsecs (/ step 1000.0)))
 232       (when id
 233         (condition-case nil
 234             (while (and (> time 0)
 235                         (not (fuel-con--connection-completed-p con id)))
 236               (accept-process-output nil waitsecs)
 237               (setq time (- time step)))
 238           (error (setq time 1)))
 239         (or (> time 0)
 240             (fuel-con--request-deactivate req)
 241             nil)))))
 242
 243 \f
 244 (provide 'fuel-connection)
 245 ;;; fuel-connection.el ends here