Merge branch 'master' into comment-cache
[emacs.git] / lisp / emacs-lisp / tq.el
blob3f5d78df31c2e97d1b31ebf067e5d56a65f7b2fb
1 ;;; tq.el --- utility to maintain a transaction queue -*- lexical-binding:t -*-
3 ;; Copyright (C) 1985-1987, 1992, 2001-2017 Free Software Foundation,
4 ;; Inc.
6 ;; Author: Scott Draves <spot@cs.cmu.edu>
7 ;; Maintainer: emacs-devel@gnu.org
8 ;; Adapted-By: ESR
9 ;; Keywords: extensions
11 ;; This file is part of GNU Emacs.
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.
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.
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/>.
26 ;;; Commentary:
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.
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.
36 ;; A transaction queue may be created by calling `tq-create'.
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.
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.
50 ;;; Code:
52 ;;; Accessors
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)))
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))))))
73 ;; Determine whether queue is empty
74 (defun tq-queue-empty (tq) (not (tq-queue tq)))
76 ;;; Core functionality
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))
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)
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)))
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.
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.
114 REGEXP is a regular expression to match the entire answer;
115 that's how we tell where the answer ends.
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))))
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)))
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)))))
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))))))))
167 (provide 'tq)
169 ;;; tq.el ends here