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
  45 (defsubst fuel-con--request-p (req)
  46   (and (listp req) (eq (car req) :fuel-connection-request)))
  47
  48 (defsubst fuel-con--request-id (req)
  49   (cdr (assoc :id req)))
  50
  51 (defsubst fuel-con--request-string (req)
  52   (cdr (assoc :string req)))
  53
  54 (defsubst fuel-con--request-continuation (req)
  55   (cdr (assoc :continuation req)))
  56
  57 (defsubst fuel-con--request-buffer (req)
  58   (cdr (assoc :buffer req)))
  59
  60 (defsubst fuel-con--request-deactivate (req)
  61   (setcdr (assoc :continuation req) nil))
  62
  63 (defsubst fuel-con--request-deactivated-p (req)
  64   (null (cdr (assoc :continuation req))))
  65
  66 (defsubst fuel-con--make-connection (buffer)
  67   (list :fuel-connection
  68         (list :requests)
  69         (list :current)
  70         (cons :completed (make-hash-table :weakness 'value))
  71         (cons :buffer buffer)))
  72
  73 (defsubst fuel-con--connection-p (c)
  74   (and (listp c) (eq (car c) :fuel-connection)))
  75
  76 (defsubst fuel-con--connection-requests (c)
  77   (cdr (assoc :requests c)))
  78
  79 (defsubst fuel-con--connection-current-request (c)
  80   (cdr (assoc :current c)))
  81
  82 (defun fuel-con--connection-clean-current-request (c)
  83   (let* ((cell (assoc :current c))
  84          (req (cdr cell)))
  85     (when req
  86       (puthash (fuel-con--request-id req) req (cdr (assoc :completed c)))
  87       (setcdr cell nil))))
  88
  89 (defsubst fuel-con--connection-completed-p (c id)
  90   (gethash id (cdr (assoc :completed c))))
  91
  92 (defsubst fuel-con--connection-buffer (c)
  93   (cdr (assoc :buffer c)))
  94
  95 (defun fuel-con--connection-pop-request (c)
  96   (let ((reqs (assoc :requests c))
  97         (current (assoc :current c)))
  98     (setcdr current (prog1 (cadr reqs) (setcdr reqs (cddr reqs))))
  99     (if (and current (fuel-con--request-deactivated-p current))
 100         (fuel-con--connection-pop-request c)
 101       current)))
 102
 103 \f
 104 ;;; Connection setup:
 105
 106 (defun fuel-con--setup-connection (buffer)
 107   (set-buffer buffer)
 108   (let ((conn (fuel-con--make-connection buffer)))
 109     (fuel-con--setup-comint)
 110     (setq fuel-con--connection conn)))
 111
 112 (defun fuel-con--setup-comint ()
 113   (add-hook 'comint-redirect-filter-functions
 114             'fuel-con--comint-redirect-filter t t))
 115
 116 \f
 117 ;;; Requests handling:
 118
 119 (defun fuel-con--process-next (con)
 120   (when (not (fuel-con--connection-current-request con))
 121     (let* ((buffer (fuel-con--connection-buffer con))
 122            (req (fuel-con--connection-pop-request con))
 123            (str (and req (fuel-con--request-string req))))
 124       (when (and buffer req str)
 125         (set-buffer buffer)
 126         (comint-redirect-send-command str
 127                                       (get-buffer-create "*factor messages*")
 128                                       nil
 129                                       t)))))
 130
 131 (defun fuel-con--comint-redirect-filter (str)
 132   (if (not fuel-con--connection)
 133       (format "\nERROR: No connection in buffer (%s)\n" str)
 134     (let ((req (fuel-con--connection-current-request fuel-con--connection)))
 135       (if (not req) (format "\nERROR: No current request (%s)\n" str)
 136         (let ((cont (fuel-con--request-continuation req))
 137               (id (fuel-con--request-id req))
 138               (rstr (fuel-con--request-string req))
 139               (buffer (fuel-con--request-buffer req)))
 140           (prog1
 141               (if (not cont)
 142                   (format "\nWARNING: Droping result for request %s:%S (%s)\n"
 143                           id rstr str)
 144                 (condition-case cerr
 145                     (with-current-buffer (or buffer (current-buffer))
 146                       (funcall cont str)
 147                       (format "\nINFO: %s:%S processed\nINFO: %s\n" id rstr str))
 148                   (error (format "\nERROR: continuation failed %s:%S \nERROR: %s\n"
 149                                  id rstr cerr))))
 150             (fuel-con--connection-clean-current-request fuel-con--connection)))))))
 151
 152 \f
 153 ;;; Message sending interface:
 154
 155 (defun fuel-con--send-string (buffer/proc str cont &optional sender-buffer)
 156   (save-current-buffer
 157     (let ((con (fuel-con--get-connection buffer/proc)))
 158       (unless con
 159         (error "FUEL: couldn't find connection"))
 160       (let ((req (fuel-con--make-request str cont sender-buffer)))
 161         (fuel-con--connection-queue-request con req)
 162         (fuel-con--process-next con)
 163         req))))
 164
 165 (defvar fuel-connection-timeout 30000
 166   "Time limit, in msecs, blocking on synchronous evaluation requests")
 167
 168 (defun fuel-con--send-string/wait (buffer/proc str cont &optional timeout sbuf)
 169   (save-current-buffer
 170     (let* ((con (fuel-con--get-connection buffer/proc))
 171          (req (fuel-con--send-string buffer/proc str cont sbuf))
 172          (id (and req (fuel-con--request-id req)))
 173          (time (or timeout fuel-connection-timeout))
 174          (step 2))
 175       (when id
 176         (while (and (> time 0)
 177                     (not (fuel-con--connection-completed-p con id)))
 178           (sleep-for 0 step)
 179           (setq time (- time step)))
 180         (or (> time 0)
 181             (fuel-con--request-deactivate req)
 182             nil)))))
 183
 184 \f
 185 (provide 'fuel-connection)
 186 ;;; fuel-connection.el ends here