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