lisp/emacs-lisp/tq.el

   1 ;;; tq.el --- utility to maintain a transaction queue
   2
   3 ;; Copyright (C) 1985-1987, 1992, 2001-2011 Free Software Foundation, Inc.
   4
   5 ;; Author: Scott Draves <spot@cs.cmu.edu>
   6 ;; Maintainer: FSF
   7 ;; Adapted-By: ESR
   8 ;; Keywords: extensions
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; This file manages receiving a stream asynchronously, parsing it
  28 ;; into transactions, and then calling the associated handler function
  29 ;; upon the completion of each transaction.
  30
  31 ;; Our basic structure is the queue/process/buffer triple.  Each entry
  32 ;; of the queue part is a list of question, regexp, closure, and
  33 ;; function that is consed to the last element.
  34
  35 ;; A transaction queue may be created by calling `tq-create'.
  36
  37 ;; A request may be added to the queue by calling `tq-enqueue'.  If
  38 ;; the `delay-question' argument is non-nil, we will wait to send the
  39 ;; question to the process until it has finished sending other input.
  40 ;; Otherwise, once a request is enqueued, we send the given question
  41 ;; immediately to the process.
  42
  43 ;; We then buffer bytes from the process until we see the regexp that
  44 ;; was provided in the call to `tq-enqueue'.  Then we call the
  45 ;; provided function with the closure and the collected bytes.  If we
  46 ;; have indicated that the question from the next transaction was not
  47 ;; sent immediately, send it at this point, awaiting the response.
  48
  49 ;;; Code:
  50
  51 ;;; Accessors
  52
  53 ;; This part looks like (queue . (process . buffer))
  54 (defun tq-queue               (tq) (car tq))
  55 (defun tq-process             (tq) (car (cdr tq)))
  56 (defun tq-buffer              (tq) (cdr (cdr tq)))
  57
  58 ;; The structure of `queue' is as follows
  59 ;; ((question regexp closure . fn)
  60 ;;  <other queue entries>)
  61 ;; question: string to send to the process
  62 (defun tq-queue-head-question (tq) (car (car (tq-queue tq))))
  63 ;; regexp: regular expression that matches the end of a response from
  64 ;; the process
  65 (defun tq-queue-head-regexp   (tq) (car (cdr (car (tq-queue tq)))))
  66 ;; closure: additional data to pass to the function
  67 (defun tq-queue-head-closure  (tq) (car (cdr (cdr (car (tq-queue tq))))))
  68 ;; fn: function to call upon receiving a complete response from the
  69 ;; process
  70 (defun tq-queue-head-fn       (tq) (cdr (cdr (cdr (car (tq-queue tq))))))
  71
  72 ;; Determine whether queue is empty
  73 (defun tq-queue-empty         (tq) (not (tq-queue tq)))
  74
  75 ;;; Core functionality
  76
  77 ;;;###autoload
  78 (defun tq-create (process)
  79   "Create and return a transaction queue communicating with PROCESS.
  80 PROCESS should be a subprocess capable of sending and receiving
  81 streams of bytes.  It may be a local process, or it may be connected
  82 to a tcp server on another machine."
  83   (let ((tq (cons nil (cons process
  84                             (generate-new-buffer
  85                              (concat " tq-temp-"
  86                                      (process-name process)))))))
  87     (buffer-disable-undo (tq-buffer tq))
  88     (set-process-filter process
  89                         `(lambda (proc string)
  90                            (tq-filter ',tq string)))
  91     tq))
  92
  93 (defun tq-queue-add (tq question re closure fn)
  94   (setcar tq (nconc (tq-queue tq)
  95                     (cons (cons question (cons re (cons closure fn))) nil)))
  96   'ok)
  97
  98 (defun tq-queue-pop (tq)
  99   (setcar tq (cdr (car tq)))
 100   (let ((question (tq-queue-head-question tq)))
 101     (condition-case nil
 102         (process-send-string (tq-process tq) question)
 103       (error nil)))
 104   (null (car tq)))
 105
 106 (defun tq-enqueue (tq question regexp closure fn &optional delay-question)
 107   "Add a transaction to transaction queue TQ.
 108 This sends the string QUESTION to the process that TQ communicates with.
 109
 110 When the corresponding answer comes back, we call FN with two
 111 arguments: CLOSURE, which may contain additional data that FN
 112 needs, and the answer to the question.
 113
 114 REGEXP is a regular expression to match the entire answer;
 115 that's how we tell where the answer ends.
 116
 117 If DELAY-QUESTION is non-nil, delay sending this question until
 118 the process has finished replying to any previous questions.
 119 This produces more reliable results with some processes."
 120   (let ((sendp (or (not delay-question)
 121                    (not (tq-queue tq)))))
 122     (tq-queue-add tq (unless sendp question) regexp closure fn)
 123     (when sendp
 124       (process-send-string (tq-process tq) question))))
 125
 126 (defun tq-close (tq)
 127   "Shut down transaction queue TQ, terminating the process."
 128   (delete-process (tq-process tq))
 129   (kill-buffer (tq-buffer tq)))
 130
 131 (defun tq-filter (tq string)
 132   "Append STRING to the TQ's buffer; then process the new data."
 133   (let ((buffer (tq-buffer tq)))
 134     (when (buffer-live-p buffer)
 135       (with-current-buffer buffer
 136         (goto-char (point-max))
 137         (insert string)
 138         (tq-process-buffer tq)))))
 139
 140 (defun tq-process-buffer (tq)
 141   "Check TQ's buffer for the regexp at the head of the queue."
 142   (let ((buffer (tq-buffer tq)))
 143     (when (buffer-live-p buffer)
 144       (set-buffer buffer)
 145       (if (= 0 (buffer-size)) ()
 146         (if (tq-queue-empty tq)
 147             (let ((buf (generate-new-buffer "*spurious*")))
 148               (copy-to-buffer buf (point-min) (point-max))
 149               (delete-region (point-min) (point))
 150               (pop-to-buffer buf nil)
 151               (error "Spurious communication from process %s, see buffer %s"
 152                      (process-name (tq-process tq))
 153                      (buffer-name buf)))
 154           (goto-char (point-min))
 155           (if (re-search-forward (tq-queue-head-regexp tq) nil t)
 156               (let ((answer (buffer-substring (point-min) (point))))
 157                 (delete-region (point-min) (point))
 158                 (unwind-protect
 159                     (condition-case nil
 160                         (funcall (tq-queue-head-fn tq)
 161                                  (tq-queue-head-closure tq)
 162                                  answer)
 163                       (error nil))
 164                   (tq-queue-pop tq))
 165                 (tq-process-buffer tq))))))))
 166
 167 (provide 'tq)
 168
 169 ;;; tq.el ends here