lisp/emacs-lisp/tq.el

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