Mercurial > emacs
annotate lisp/emacs-lisp/tq.el @ 67892:e188efbb47ee
(Using Customize): New node.
author | Romain Francoise <romain@orebokech.com> |
---|---|
date | Thu, 29 Dec 2005 14:08:09 +0000 |
parents | 5b1a238fcbb4 |
children | 067115a6e738 2d92f5c9d6ae |
rev | line source |
---|---|
743 | 1 ;;; tq.el --- utility to maintain a transaction queue |
2 | |
64751
5b1a238fcbb4
Update years in copyright notice; nfc.
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
64085
diff
changeset
|
3 ;; Copyright (C) 1985, 1986, 1987, 1992, 2002, 2003, 2004, |
5b1a238fcbb4
Update years in copyright notice; nfc.
Thien-Thi Nguyen <ttn@gnuvola.org>
parents:
64085
diff
changeset
|
4 ;; 2005 Free Software Foundation, Inc. |
841 | 5 |
783
59dc833c4e0c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
743
diff
changeset
|
6 ;; Author: Scott Draves <spot@cs.cmu.edu> |
39461 | 7 ;; Maintainer: FSF |
783
59dc833c4e0c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
743
diff
changeset
|
8 ;; Adapted-By: ESR |
814
38b2499cb3e9
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
783
diff
changeset
|
9 ;; Keywords: extensions |
783
59dc833c4e0c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
743
diff
changeset
|
10 |
841 | 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 2, 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 | |
14169 | 24 ;; along with GNU Emacs; see the file COPYING. If not, write to the |
64085 | 25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
26 ;; Boston, MA 02110-1301, USA. | |
841 | 27 |
28 ;;; Commentary: | |
49598
0d8b17d428b5
Trailing whitepace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
39568
diff
changeset
|
29 |
39568
e67950065cf9
Change ;;; to ;; for outline-minor-mode.
Gerd Moellmann <gerd@gnu.org>
parents:
39461
diff
changeset
|
30 ;; manages receiving a stream asynchronously, |
e67950065cf9
Change ;;; to ;; for outline-minor-mode.
Gerd Moellmann <gerd@gnu.org>
parents:
39461
diff
changeset
|
31 ;; parsing it into transactions, and then calling |
e67950065cf9
Change ;;; to ;; for outline-minor-mode.
Gerd Moellmann <gerd@gnu.org>
parents:
39461
diff
changeset
|
32 ;; handler functions |
743 | 33 |
39568
e67950065cf9
Change ;;; to ;; for outline-minor-mode.
Gerd Moellmann <gerd@gnu.org>
parents:
39461
diff
changeset
|
34 ;; Our basic structure is the queue/process/buffer triple. Each entry |
e67950065cf9
Change ;;; to ;; for outline-minor-mode.
Gerd Moellmann <gerd@gnu.org>
parents:
39461
diff
changeset
|
35 ;; of the queue is a regexp/closure/function triple. We buffer |
e67950065cf9
Change ;;; to ;; for outline-minor-mode.
Gerd Moellmann <gerd@gnu.org>
parents:
39461
diff
changeset
|
36 ;; bytes from the process until we see the regexp at the head of the |
e67950065cf9
Change ;;; to ;; for outline-minor-mode.
Gerd Moellmann <gerd@gnu.org>
parents:
39461
diff
changeset
|
37 ;; queue. Then we call the function with the closure and the |
e67950065cf9
Change ;;; to ;; for outline-minor-mode.
Gerd Moellmann <gerd@gnu.org>
parents:
39461
diff
changeset
|
38 ;; collected bytes. |
743 | 39 |
783
59dc833c4e0c
*** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
743
diff
changeset
|
40 ;;; Code: |
743 | 41 |
1187
519c04d69cdc
Doc fixes. Make tq-create autoload.
Richard M. Stallman <rms@gnu.org>
parents:
841
diff
changeset
|
42 ;;;###autoload |
743 | 43 (defun tq-create (process) |
1187
519c04d69cdc
Doc fixes. Make tq-create autoload.
Richard M. Stallman <rms@gnu.org>
parents:
841
diff
changeset
|
44 "Create and return a transaction queue communicating with PROCESS. |
519c04d69cdc
Doc fixes. Make tq-create autoload.
Richard M. Stallman <rms@gnu.org>
parents:
841
diff
changeset
|
45 PROCESS should be a subprocess capable of sending and receiving |
519c04d69cdc
Doc fixes. Make tq-create autoload.
Richard M. Stallman <rms@gnu.org>
parents:
841
diff
changeset
|
46 streams of bytes. It may be a local process, or it may be connected |
519c04d69cdc
Doc fixes. Make tq-create autoload.
Richard M. Stallman <rms@gnu.org>
parents:
841
diff
changeset
|
47 to a tcp server on another machine." |
743 | 48 (let ((tq (cons nil (cons process |
49 (generate-new-buffer | |
50 (concat " tq-temp-" | |
51 (process-name process))))))) | |
52 (set-process-filter process | |
49851
fec321336b72
(tq-create): Fix quoted lambda.
Juanma Barranquero <lekktu@gmail.com>
parents:
49598
diff
changeset
|
53 `(lambda (proc string) |
52493
04f194e85b4d
(tq-create): Fix mixed up unquote style.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
52401
diff
changeset
|
54 (tq-filter ',tq string))) |
743 | 55 tq)) |
56 | |
57 ;;; accessors | |
58 (defun tq-queue (tq) (car tq)) | |
59 (defun tq-process (tq) (car (cdr tq))) | |
60 (defun tq-buffer (tq) (cdr (cdr tq))) | |
61 | |
62 (defun tq-queue-add (tq re closure fn) | |
63 (setcar tq (nconc (tq-queue tq) | |
64 (cons (cons re (cons closure fn)) nil))) | |
65 'ok) | |
66 | |
67 (defun tq-queue-head-regexp (tq) (car (car (tq-queue tq)))) | |
68 (defun tq-queue-head-fn (tq) (cdr (cdr (car (tq-queue tq))))) | |
69 (defun tq-queue-head-closure (tq) (car (cdr (car (tq-queue tq))))) | |
70 (defun tq-queue-empty (tq) (not (tq-queue tq))) | |
71 (defun tq-queue-pop (tq) (setcar tq (cdr (car tq))) (null (car tq))) | |
49598
0d8b17d428b5
Trailing whitepace deleted.
Juanma Barranquero <lekktu@gmail.com>
parents:
39568
diff
changeset
|
72 |
743 | 73 |
74 ;;; must add to queue before sending! | |
75 (defun tq-enqueue (tq question regexp closure fn) | |
1187
519c04d69cdc
Doc fixes. Make tq-create autoload.
Richard M. Stallman <rms@gnu.org>
parents:
841
diff
changeset
|
76 "Add a transaction to transaction queue TQ. |
519c04d69cdc
Doc fixes. Make tq-create autoload.
Richard M. Stallman <rms@gnu.org>
parents:
841
diff
changeset
|
77 This sends the string QUESTION to the process that TQ communicates with. |
519c04d69cdc
Doc fixes. Make tq-create autoload.
Richard M. Stallman <rms@gnu.org>
parents:
841
diff
changeset
|
78 When the corresponding answer comes back, we call FN |
519c04d69cdc
Doc fixes. Make tq-create autoload.
Richard M. Stallman <rms@gnu.org>
parents:
841
diff
changeset
|
79 with two arguments: CLOSURE, and the answer to the question. |
519c04d69cdc
Doc fixes. Make tq-create autoload.
Richard M. Stallman <rms@gnu.org>
parents:
841
diff
changeset
|
80 REGEXP is a regular expression to match the entire answer; |
519c04d69cdc
Doc fixes. Make tq-create autoload.
Richard M. Stallman <rms@gnu.org>
parents:
841
diff
changeset
|
81 that's how we tell where the answer ends." |
743 | 82 (tq-queue-add tq regexp closure fn) |
83 (process-send-string (tq-process tq) question)) | |
84 | |
85 (defun tq-close (tq) | |
1187
519c04d69cdc
Doc fixes. Make tq-create autoload.
Richard M. Stallman <rms@gnu.org>
parents:
841
diff
changeset
|
86 "Shut down transaction queue TQ, terminating the process." |
743 | 87 (delete-process (tq-process tq)) |
88 (kill-buffer (tq-buffer tq))) | |
89 | |
90 (defun tq-filter (tq string) | |
91 "Append STRING to the TQ's buffer; then process the new data." | |
20693
b48b8060e70d
(tq-filter): Use with-current-buffer.
Richard M. Stallman <rms@gnu.org>
parents:
17216
diff
changeset
|
92 (with-current-buffer (tq-buffer tq) |
b48b8060e70d
(tq-filter): Use with-current-buffer.
Richard M. Stallman <rms@gnu.org>
parents:
17216
diff
changeset
|
93 (goto-char (point-max)) |
b48b8060e70d
(tq-filter): Use with-current-buffer.
Richard M. Stallman <rms@gnu.org>
parents:
17216
diff
changeset
|
94 (insert string) |
b48b8060e70d
(tq-filter): Use with-current-buffer.
Richard M. Stallman <rms@gnu.org>
parents:
17216
diff
changeset
|
95 (tq-process-buffer tq))) |
743 | 96 |
97 (defun tq-process-buffer (tq) | |
98 "Check TQ's buffer for the regexp at the head of the queue." | |
99 (set-buffer (tq-buffer tq)) | |
100 (if (= 0 (buffer-size)) () | |
101 (if (tq-queue-empty tq) | |
102 (let ((buf (generate-new-buffer "*spurious*"))) | |
103 (copy-to-buffer buf (point-min) (point-max)) | |
104 (delete-region (point-min) (point)) | |
105 (pop-to-buffer buf nil) | |
14430
408eeedc18cd
(tq-process-buffer): Fix error format string.
Karl Heuer <kwzh@gnu.org>
parents:
14169
diff
changeset
|
106 (error "Spurious communication from process %s, see buffer %s" |
408eeedc18cd
(tq-process-buffer): Fix error format string.
Karl Heuer <kwzh@gnu.org>
parents:
14169
diff
changeset
|
107 (process-name (tq-process tq)) |
408eeedc18cd
(tq-process-buffer): Fix error format string.
Karl Heuer <kwzh@gnu.org>
parents:
14169
diff
changeset
|
108 (buffer-name buf))) |
743 | 109 (goto-char (point-min)) |
110 (if (re-search-forward (tq-queue-head-regexp tq) nil t) | |
111 (let ((answer (buffer-substring (point-min) (point)))) | |
112 (delete-region (point-min) (point)) | |
17216
ef3033d89075
(tq-process-buffer): Catch errors running tq-queue-head-fn.
Richard M. Stallman <rms@gnu.org>
parents:
16235
diff
changeset
|
113 (unwind-protect |
ef3033d89075
(tq-process-buffer): Catch errors running tq-queue-head-fn.
Richard M. Stallman <rms@gnu.org>
parents:
16235
diff
changeset
|
114 (condition-case nil |
ef3033d89075
(tq-process-buffer): Catch errors running tq-queue-head-fn.
Richard M. Stallman <rms@gnu.org>
parents:
16235
diff
changeset
|
115 (funcall (tq-queue-head-fn tq) |
ef3033d89075
(tq-process-buffer): Catch errors running tq-queue-head-fn.
Richard M. Stallman <rms@gnu.org>
parents:
16235
diff
changeset
|
116 (tq-queue-head-closure tq) |
ef3033d89075
(tq-process-buffer): Catch errors running tq-queue-head-fn.
Richard M. Stallman <rms@gnu.org>
parents:
16235
diff
changeset
|
117 answer) |
ef3033d89075
(tq-process-buffer): Catch errors running tq-queue-head-fn.
Richard M. Stallman <rms@gnu.org>
parents:
16235
diff
changeset
|
118 (error nil)) |
ef3033d89075
(tq-process-buffer): Catch errors running tq-queue-head-fn.
Richard M. Stallman <rms@gnu.org>
parents:
16235
diff
changeset
|
119 (tq-queue-pop tq)) |
743 | 120 (tq-process-buffer tq)))))) |
121 | |
841 | 122 (provide 'tq) |
123 | |
52401 | 124 ;;; arch-tag: 65dea08c-4edd-4cde-83a5-e8a15b993b79 |
743 | 125 ;;; tq.el ends here |