lisp/emacs-lisp/tq.el

   1 ;;; tq.el --- utility to maintain a transaction queue  -*- lexical-binding:t -*-
   2
   3 ;; Copyright (C) 1985-1987, 1992, 2001-2014 Free Software Foundation,
   4 ;; 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 of the License, or
  16 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
  25
  26 ;;; Commentary:
  27
  28 ;; This file manages receiving a stream asynchronously, parsing it
  29 ;; into transactions, and then calling the associated handler function
  30 ;; upon the completion of each transaction.
  31
  32 ;; Our basic structure is the queue/process/buffer triple.  Each entry
  33 ;; of the queue part is a list of question, regexp, closure, and
  34 ;; function that is consed to the last element.
  35
  36 ;; A transaction queue may be created by calling `tq-create'.
  37
  38 ;; A request may be added to the queue by calling `tq-enqueue'.  If
  39 ;; the `delay-question' argument is non-nil, we will wait to send the
  40 ;; question to the process until it has finished sending other input.
  41 ;; Otherwise, once a request is enqueued, we send the given question
  42 ;; immediately to the process.
  43
  44 ;; We then buffer bytes from the process until we see the regexp that
  45 ;; was provided in the call to `tq-enqueue'.  Then we call the
  46 ;; provided function with the closure and the collected bytes.  If we
  47 ;; have indicated that the question from the next transaction was not
  48 ;; sent immediately, send it at this point, awaiting the response.
  49
  50 ;;; Code:
  51
  52 ;;; Accessors
  53
  54 ;; This part looks like (queue . (process . buffer))
  55 (defun tq-queue               (tq) (car tq))
  56 (defun tq-process             (tq) (car (cdr tq)))
  57 (defun tq-buffer              (tq) (cdr (cdr tq)))
  58
  59 ;; The structure of `queue' is as follows
  60 ;; ((question regexp closure . fn)
  61 ;;  <other queue entries>)
  62 ;; question: string to send to the process
  63 (defun tq-queue-head-question (tq) (car (car (tq-queue tq))))
  64 ;; regexp: regular expression that matches the end of a response from
  65 ;; the process
  66 (defun tq-queue-head-regexp   (tq) (car (cdr (car (tq-queue tq)))))
  67 ;; closure: additional data to pass to the function
  68 (defun tq-queue-head-closure  (tq) (car (cdr (cdr (car (tq-queue tq))))))
  69 ;; fn: function to call upon receiving a complete response from the
  70 ;; process
  71 (defun tq-queue-head-fn       (tq) (cdr (cdr (cdr (car (tq-queue tq))))))
  72
  73 ;; Determine whether queue is empty
  74 (defun tq-queue-empty         (tq) (not (tq-queue tq)))
  75
  76 ;;; Core functionality
  77
  78 ;;;###autoload
  79 (defun tq-create (process)
  80   "Create and return a transaction queue communicating with PROCESS.
  81 PROCESS should be a subprocess capable of sending and receiving
  82 streams of bytes.  It may be a local process, or it may be connected
  83 to a tcp server on another machine."
  84   (let ((tq (cons nil (cons process
  85                             (generate-new-buffer
  86                              (concat " tq-temp-"
  87                                      (process-name process)))))))
  88     (buffer-disable-undo (tq-buffer tq))
  89     (set-process-filter process
  90                         (lambda (_proc string) (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