lisp/emacs-lisp/tq.el

   1 ;;; tq.el --- utility to maintain a transaction queue
   2
   3 ;; Author: Scott Draves <spot@cs.cmu.edu>
   4 ;; Adapted-By: ESR
   5 ;; Keywords: extensions
   6
   7 ;; Commentary:
   8
   9 ;;; manages receiving a stream asynchronously,
  10 ;;; parsing it into transactions, and then calling
  11 ;;; handler functions
  12
  13 ;;; Our basic structure is the queue/process/buffer triple.  Each entry
  14 ;;; of the queue is a regexp/closure/function triple.  We buffer
  15 ;;; bytes from the process until we see the regexp at the head of the
  16 ;;; queue.  Then we call the function with the closure and the
  17 ;;; collected bytes.
  18
  19 ;;; Code:
  20
  21 (provide 'tq)
  22
  23 (defun tq-create (process)
  24   "Create and return a transaction queue.  PROCESS should be capable
  25 of sending and receiving streams of bytes.  It may be a local process,
  26 or it may be connected to a tcp server on another machine."
  27   (let ((tq (cons nil (cons process
  28                             (generate-new-buffer
  29                              (concat " tq-temp-"
  30                                      (process-name process)))))))
  31     (set-process-filter process
  32                         (`(lambda (proc string)
  33                            (tq-filter  '(, tq) string))))
  34     tq))
  35
  36 ;;; accessors
  37 (defun tq-queue   (tq) (car tq))
  38 (defun tq-process (tq) (car (cdr tq)))
  39 (defun tq-buffer  (tq) (cdr (cdr tq)))
  40
  41 (defun tq-queue-add (tq re closure fn)
  42   (setcar tq (nconc (tq-queue tq)
  43                     (cons (cons re (cons closure fn)) nil)))
  44   'ok)
  45
  46 (defun tq-queue-head-regexp  (tq) (car (car (tq-queue tq))))
  47 (defun tq-queue-head-fn      (tq) (cdr (cdr (car (tq-queue tq)))))
  48 (defun tq-queue-head-closure (tq) (car (cdr (car (tq-queue tq)))))
  49 (defun tq-queue-empty        (tq) (not (tq-queue tq)))
  50 (defun tq-queue-pop          (tq) (setcar tq (cdr (car tq))) (null (car tq)))
  51
  52
  53 ;;; must add to queue before sending!
  54 (defun tq-enqueue (tq question regexp closure fn)
  55   "Add a transaction to TQ.  Send question to the process, and call FN
  56 with CLOSURE and and the answer, when it appears.  The end of the
  57 answer is identified by REGEXP."
  58   (tq-queue-add tq regexp closure fn)
  59   (process-send-string (tq-process tq) question))
  60
  61 (defun tq-close (tq)
  62   "Shut down the process, and destroy the evidence."
  63   (delete-process (tq-process tq))
  64   (kill-buffer (tq-buffer tq)))
  65
  66 (defun tq-filter (tq string)
  67   "Append STRING to the TQ's buffer; then process the new data."
  68   (set-buffer (tq-buffer tq))
  69   (goto-char (point-max))
  70   (insert string)
  71   (tq-process-buffer tq))
  72
  73 (defun tq-process-buffer (tq)
  74   "Check TQ's buffer for the regexp at the head of the queue."
  75   (set-buffer (tq-buffer tq))
  76   (if (= 0 (buffer-size)) ()
  77     (if (tq-queue-empty tq)
  78         (let ((buf (generate-new-buffer "*spurious*")))
  79           (copy-to-buffer buf (point-min) (point-max))
  80           (delete-region (point-min) (point))
  81           (pop-to-buffer buf nil)
  82           (error (concat "Spurious communication from process "
  83                          (process-name (tq-process tq))
  84                          ", see buffer *spurious*.")))
  85       (goto-char (point-min))
  86       (if (re-search-forward (tq-queue-head-regexp tq) nil t)
  87           (let ((answer (buffer-substring (point-min) (point))))
  88             (delete-region (point-min) (point))
  89             (funcall (tq-queue-head-fn tq)
  90                      (tq-queue-head-closure tq)
  91                      answer)
  92             (tq-queue-pop tq)
  93             (tq-process-buffer tq))))))
  94
  95 ;;; tq.el ends here