|
0
|
1 ;;; -*-Emacs-Lisp-*-
|
|
|
2 ;;;
|
|
|
3 ;;;
|
|
|
4 ;;;%Header
|
|
|
5 ;;;
|
|
|
6 ;;; Rcs_Info: comint-ipc.el,v 1.20 1993/09/03 02:05:07 ivan Rel $
|
|
|
7 ;;;
|
|
|
8 ;;; IPC extensions for comint
|
|
|
9 ;;; Copyright (C) 1990 Chris McConnell, ccm@cs.cmu.edu.
|
|
|
10 ;;;
|
|
|
11 ;;; Send mail to ilisp@lehman.com if you have problems.
|
|
|
12 ;;;
|
|
|
13 ;;; Send mail to ilisp-request@lehman.com if you want to be on the
|
|
|
14 ;;; ilisp mailing list.
|
|
|
15
|
|
|
16 ;;; This file is part of GNU Emacs.
|
|
|
17
|
|
|
18 ;;; GNU Emacs is distributed in the hope that it will be useful,
|
|
|
19 ;;; but WITHOUT ANY WARRANTY. No author or distributor
|
|
|
20 ;;; accepts responsibility to anyone for the consequences of using it
|
|
|
21 ;;; or for whether it serves any particular purpose or works at all,
|
|
|
22 ;;; unless he says so in writing. Refer to the GNU Emacs General Public
|
|
|
23 ;;; License for full details.
|
|
|
24
|
|
|
25 ;;; Everyone is granted permission to copy, modify and redistribute
|
|
|
26 ;;; GNU Emacs, but only under the conditions described in the
|
|
|
27 ;;; GNU Emacs General Public License. A copy of this license is
|
|
|
28 ;;; supposed to have been given to you along with GNU Emacs so you
|
|
|
29 ;;; can know your rights and responsibilities. It should be in a
|
|
|
30 ;;; file named COPYING. Among other things, the copyright notice
|
|
|
31 ;;; and this notice must be preserved on all copies.
|
|
|
32
|
|
|
33 ;;; This file contains extensions to multiplex the single channel of
|
|
|
34 ;;; an inferior process between multiple purposes. It provides both
|
|
|
35 ;;; synchronous and asynchronous sends with error handling.
|
|
|
36
|
|
|
37 ;;; USAGE: Load this file and call comint-setup-ipc in a comint
|
|
|
38 ;;; buffer. This is not a standalone application. For an example of
|
|
|
39 ;;; it being used see ilisp.el.
|
|
|
40
|
|
|
41 ;;; CUSTOMIZATION: See the parameters and hooks below.
|
|
|
42
|
|
|
43 ;;; INTERFACE. See the function documentation and code for more information.
|
|
|
44 ;;;
|
|
|
45 ;;; PROCESS INPUT: comint-send, comint-send-code, comint-default-send,
|
|
|
46 ;;; comint-sync, comint-abort-sends
|
|
|
47 ;;;
|
|
|
48 ;;; PROCESS OUTPUT: comint-display-output, comint-display-error-output
|
|
|
49
|
|
|
50
|
|
|
51 ;;;%Parameters
|
|
|
52 (defvar comint-log nil
|
|
|
53 "If T, then record all process input and output in a buffer called
|
|
|
54 process name.")
|
|
|
55
|
|
|
56 (defvar comint-send-newline t
|
|
|
57 "If T then add a newline to string in comint-default-send.")
|
|
|
58
|
|
|
59 (defvar comint-always-scroll nil
|
|
|
60 "If T then process output will always be visible in first window on buffer.")
|
|
|
61
|
|
|
62 (defvar comint-fix-error nil
|
|
|
63 "String to send to send to the command interpreter to fix errors.")
|
|
|
64
|
|
|
65 (defvar comint-continue nil
|
|
|
66 "String to send to continue an interrupted job.")
|
|
|
67
|
|
|
68 (defvar comint-interrupt-regexp nil
|
|
|
69 "Regular expression for the start of an interrupt in process output.")
|
|
|
70
|
|
|
71 (defvar comint-error-regexp nil
|
|
|
72 "Regular expression for setting comint-errorp if found in process output.")
|
|
|
73
|
|
|
74 (defvar comint-output-buffer " *Output*"
|
|
|
75 "Name of the output buffer.")
|
|
|
76
|
|
|
77 (defvar comint-error-buffer " *Error Output*"
|
|
|
78 "Name of the error output buffer.")
|
|
|
79
|
|
|
80 (defvar comint-show-status t
|
|
|
81 "Set to nil to inhibit status redisplay.")
|
|
|
82
|
|
|
83 ;;;%%Hooks
|
|
|
84 (defvar comint-output-filter (function identity)
|
|
|
85 "Given the complete OUTPUT of a send, return the result of the send.")
|
|
|
86
|
|
|
87 (defvar comint-interrupt-start 'comint-interrupt-start
|
|
|
88 "Return the start in OUTPUT of the text printed by
|
|
|
89 comint-interrupt-subjob in the inferior process.")
|
|
|
90
|
|
|
91 (defvar comint-handler 'comint-error-popup
|
|
|
92 "Default handler for sends. When a send completes, the handler is
|
|
|
93 called with error-p, wait-p, message, output and prompt.")
|
|
|
94
|
|
|
95 (defvar comint-update-status 'comint-update-status
|
|
|
96 "Function to update the STATUS of the inferior process. It should
|
|
|
97 set comint-status to a status string in addition to whatever else it
|
|
|
98 does.")
|
|
|
99
|
|
|
100 (defvar comint-prompt-status 'comint-prompt-status
|
|
|
101 "Given the previous prompt and the last line output, return 'error
|
|
|
102 if an error, T if a prompt and nil otherwise. If it is a prompt, also
|
|
|
103 funcall comint-update-status to set the status. If old is nil, then
|
|
|
104 just return T if last line is a prompt.")
|
|
|
105
|
|
|
106 ;;;
|
|
|
107 (defvar comint-abort-hook nil
|
|
|
108 "List of hooks to run after sends are aborted.")
|
|
|
109
|
|
|
110 ;;;%Globals
|
|
|
111 (defvar comint-send-queue nil
|
|
|
112 "List of currently pending IPC send requests. The first element in
|
|
|
113 the queue is where output to the process will be stored.
|
|
|
114 A send record is a list of:
|
|
|
115
|
|
|
116 string -- The string sent to the process.
|
|
|
117
|
|
|
118 no-insert -- nil to insert output into the process buffer. If this is
|
|
|
119 being done, the results will only contain the very last line.
|
|
|
120
|
|
|
121 wait-p -- nil if not waiting, non-nil if waiting. If it is a string,
|
|
|
122 results are inserted in the buffer until a result matches the string
|
|
|
123 as a regexp.
|
|
|
124
|
|
|
125 status -- A symbol for the process status while the send is running.
|
|
|
126
|
|
|
127 message -- A message to be displayed when an asynchronous send is
|
|
|
128 popped up by the handler.
|
|
|
129
|
|
|
130 handler -- A function that given error-p, wait-p, message, output and
|
|
|
131 prompt decides if the user should be notified. If it is nil or
|
|
|
132 returns nil, then no error processing will be done.
|
|
|
133
|
|
|
134 running -- nil if a send is waiting, T if it is running, another send
|
|
|
135 if interrupting and a string with pending output if the send was
|
|
|
136 interrupted.
|
|
|
137
|
|
|
138 old-prompt -- The prompt before the send was sent. If it is nil, then
|
|
|
139 errors will not be detected.
|
|
|
140
|
|
|
141 line -- The start of the last line in the results.
|
|
|
142
|
|
|
143 result -- Cons of the output and the prompt after the send.")
|
|
|
144
|
|
|
145 (defvar comint-end-queue nil "Pointer to the end of comint-send-queue.")
|
|
|
146 (defvar comint-queue-emptied t
|
|
|
147 "Set to T each time send queue empties.")
|
|
|
148
|
|
|
149 (defvar comint-output nil
|
|
|
150 "Set to the output of the last send. This is useful when ilisp code
|
|
|
151 is put in the send stream.")
|
|
|
152 (defvar comint-errorp nil
|
|
|
153 "Set to T if the last send was an error.")
|
|
|
154
|
|
|
155 (defvar comint-status " :run" "The current comint status.")
|
|
|
156 (defvar comint-original-buffer nil
|
|
|
157 "The original buffer when there was output to a comint buffer.")
|
|
|
158
|
|
|
159 (defvar comint-last-send nil "Last send that was put in queue.")
|
|
|
160
|
|
|
161 (defvar comint-aborting nil
|
|
|
162 "Set to T if we are aborting commands.")
|
|
|
163
|
|
|
164 ;;;%Utils
|
|
|
165 ;;;
|
|
|
166 (defun comint-remove-whitespace (string)
|
|
|
167 "Remove leading and trailing whitespace in STRING."
|
|
|
168 (if string
|
|
|
169 (let* ((start (if (string-match "[^ \t\n]" string)
|
|
|
170 (match-beginning 0)
|
|
|
171 0))
|
|
|
172 (end start))
|
|
|
173 (while (string-match "[ \t\n]*[^ \t\n]+" string end)
|
|
|
174 (setq end (match-end 0)))
|
|
|
175 (substring string start end))))
|
|
|
176
|
|
|
177 ;;;
|
|
|
178 (defun comint-log (process string &optional output)
|
|
|
179 "Log to PROCESS, STRING marking as optional OUTPUT."
|
|
|
180 (if comint-log
|
|
|
181 (save-excursion
|
|
|
182 (set-buffer (get-buffer-create (process-name process)))
|
|
|
183 (goto-char (point-max))
|
|
|
184 (if output
|
|
|
185 (progn
|
|
|
186 (insert "{") (insert string) (insert "}"))
|
|
|
187 (insert string)))))
|
|
|
188
|
|
|
189 ;;;
|
|
|
190 (defun comint-send-string (proc str)
|
|
|
191 "Send PROCESS the contents of STRING as input.
|
|
|
192 This is equivalent to process-send-string, except that long input strings
|
|
|
193 are broken up into chunks of size comint-input-chunk-size. Processes
|
|
|
194 are given a chance to output between chunks. This can help prevent processes
|
|
|
195 from hanging when you send them long inputs on some OS's."
|
|
|
196 (comint-log proc str)
|
|
|
197 (let* ((len (length str))
|
|
|
198 (i (min len comint-input-chunk-size)))
|
|
|
199 (process-send-string proc (substring str 0 i))
|
|
|
200 (while (< i len)
|
|
|
201 (let ((next-i (+ i comint-input-chunk-size)))
|
|
|
202 (accept-process-output)
|
|
|
203 (process-send-string proc (substring str i (min len next-i)))
|
|
|
204 (setq i next-i)))))
|
|
|
205
|
|
|
206 ;;;
|
|
|
207 (defun comint-sender (process string)
|
|
|
208 "Send to PROCESS STRING with newline if comint-send-newline."
|
|
|
209 (comint-send-string process string)
|
|
|
210 (if comint-send-newline
|
|
|
211 (progn
|
|
|
212 (comint-log process "\n")
|
|
|
213 (process-send-string process "\n"))))
|
|
|
214
|
|
|
215 ;;;
|
|
|
216 (defun comint-interrupt-subjob ()
|
|
|
217 "Interrupt the current subjob."
|
|
|
218 (interactive)
|
|
|
219 (comint-log (get-buffer-process (current-buffer)) "")
|
|
|
220 (interrupt-process nil comint-ptyp))
|
|
|
221
|
|
|
222 ;;;
|
|
|
223 (defun comint-send-variables (send)
|
|
|
224 "Return a pointer to the start of the variables for SEND. It
|
|
|
225 returns \(running old-prompt line \(output . prompt))."
|
|
|
226 (cdr (cdr (cdr (cdr (cdr (cdr send)))))))
|
|
|
227
|
|
|
228 ;;;
|
|
|
229 (defun comint-send-results (send)
|
|
|
230 "Return the results of SEND which are \(output . prompt). If there is
|
|
|
231 an error, the prompt will be a list."
|
|
|
232 (car (cdr (cdr (cdr (comint-send-variables send))))))
|
|
|
233
|
|
|
234 ;;;
|
|
|
235 (defun comint-send-description (send)
|
|
|
236 "Return a description of SEND."
|
|
|
237 (let* ((status (cdr (cdr (cdr send)))))
|
|
|
238 (or (car (cdr status)) ;Message
|
|
|
239 (and (stringp (car send)) (car send)) ;String
|
|
|
240 (and (car status) (symbol-name (car status))))))
|
|
|
241
|
|
|
242 ;;;
|
|
|
243 (defun comint-interrupted ()
|
|
|
244 "Return T if there is an interrupted send."
|
|
|
245 (let ((send comint-send-queue)
|
|
|
246 (done nil))
|
|
|
247 (while (and send (not done))
|
|
|
248 (if (stringp (car (comint-send-variables (car send))))
|
|
|
249 (setq done t)
|
|
|
250 (setq send (cdr send))))
|
|
|
251 done))
|
|
|
252
|
|
|
253
|
|
|
254 ;;;%Default hooks
|
|
|
255 (defun comint-process-sentinel (process status)
|
|
|
256 "Update PROCESS STATUS by funcalling comint-update-status."
|
|
|
257 (setq status (process-status process))
|
|
|
258 (save-excursion
|
|
|
259 (if (buffer-name (process-buffer process))
|
|
|
260 (set-buffer (process-buffer process)))
|
|
|
261 (funcall comint-update-status status)))
|
|
|
262
|
|
|
263 ;;;
|
|
|
264 (defun comint-interrupt-start (output)
|
|
|
265 "Return the start of comint-interrupt-regexp in OUTPUT."
|
|
|
266 (if (and comint-interrupt-regexp
|
|
|
267 (string-match comint-interrupt-regexp output))
|
|
|
268 (match-beginning 0)))
|
|
|
269
|
|
|
270 ;;;
|
|
|
271 (defun comint-update-status (status)
|
|
|
272 "Update the process STATUS of the current buffer."
|
|
|
273 (setq comint-status (format " :%s" status))
|
|
|
274 (if comint-show-status
|
|
|
275 (progn
|
|
|
276 (save-excursion (set-buffer (other-buffer)))
|
|
|
277 (sit-for 0))))
|
|
|
278
|
|
|
279 ;;;
|
|
|
280 (defun comint-prompt-status (old line &optional equal)
|
|
|
281 "Called by comint-process filter with OLD and LINE, return 'error if
|
|
|
282 LINE is an error, T if it is a prompt as determined by
|
|
|
283 comint-prompt-regexp or nil otherwise. Also set the status
|
|
|
284 appropriately by funcalling comint-update-status. If specified EQUAL
|
|
|
285 will be called with old and line and should return T if line is not an
|
|
|
286 error. OLD will be nil for the first prompt."
|
|
|
287 (if (string-match comint-prompt-regexp line)
|
|
|
288 (let ((error (or (if equal
|
|
|
289 (funcall equal old line)
|
|
|
290 (or (null old) (string-equal old line)))
|
|
|
291 'error)))
|
|
|
292 (funcall comint-update-status (if (eq error 'error) error 'ready))
|
|
|
293 error)
|
|
|
294 nil))
|
|
|
295
|
|
|
296 ;;;
|
|
|
297 (defun comint-insert (output)
|
|
|
298 "Insert process OUTPUT into the current buffer."
|
|
|
299 (if output
|
|
|
300 (let* ((buffer (current-buffer))
|
|
|
301 (process (get-buffer-process buffer))
|
|
|
302 (mark (process-mark process))
|
|
|
303 (window (selected-window))
|
|
|
304 (at-end nil))
|
|
|
305 (if (eq (window-buffer window) buffer)
|
|
|
306 (setq at-end (= (point) mark))
|
|
|
307 (setq window (get-buffer-window buffer)))
|
|
|
308 (save-excursion
|
|
|
309 (goto-char mark)
|
|
|
310 (insert output)
|
|
|
311 (set-marker mark (point)))
|
|
|
312 (if window
|
|
|
313 (progn
|
|
|
314 (if (or at-end comint-always-scroll) (goto-char mark))
|
|
|
315 (if (not (pos-visible-in-window-p (point) window))
|
|
|
316 (let ((original (selected-window)))
|
|
|
317 (save-excursion
|
|
|
318 (select-window window)
|
|
|
319 (recenter '(center))
|
|
|
320 (select-window original)))))))))
|
|
|
321
|
|
|
322 ;;;
|
|
|
323 (defun comint-handle-error (output prompt keys &optional delay)
|
|
|
324 "Handle an error by beeping, displaying OUTPUT and then waiting for
|
|
|
325 the user to pause. Once there is pause, PROMPT until one of the
|
|
|
326 characters in KEYS is typed. If optional DELAY is specified, it is
|
|
|
327 the number of seconds that the user must pause. The key found will be
|
|
|
328 returned."
|
|
|
329 (save-excursion
|
|
|
330 (setq delay (or delay 1))
|
|
|
331 (beep t)
|
|
|
332 (comint-display-error output)
|
|
|
333 (set-buffer comint-original-buffer)
|
|
|
334 (while (not (sit-for delay nil))
|
|
|
335 (execute-kbd-macro (read-key-sequence nil)))
|
|
|
336 (if (not (get-buffer-window (get-buffer comint-error-buffer)))
|
|
|
337 (comint-display-error output))
|
|
|
338 (let ((cursor-in-echo-area t)
|
|
|
339 (echo-keystrokes 0)
|
|
|
340 char)
|
|
|
341 (while (progn (message prompt)
|
|
|
342 (not (memq (setq char (downcase (read-char))) keys)))
|
|
|
343 (if (= char ? )
|
|
|
344 (ilisp-scroll-output)
|
|
|
345 (setq quit-flag nil)
|
|
|
346 (beep)))
|
|
|
347 char)))
|
|
|
348
|
|
|
349 ;;;
|
|
|
350 (defun comint-error-popup (error wait-p message output prompt)
|
|
|
351 "If there is an ERROR pop up a window with MESSAGE and OUTPUT.
|
|
|
352 Nothing is done with PROMPT or WAIT-P."
|
|
|
353 (if error
|
|
|
354 (save-excursion
|
|
|
355 (with-output-to-temp-buffer comint-output-buffer
|
|
|
356 (set-buffer comint-output-buffer)
|
|
|
357 (if message (insert message))
|
|
|
358 (insert ?\n)
|
|
|
359 (insert output)
|
|
|
360 (beep t))))
|
|
|
361 t)
|
|
|
362
|
|
|
363 ;;;
|
|
|
364 (defun comint-process-filter (process output)
|
|
|
365 "Filter PROCESS OUTPUT. See comint-send for more information. The
|
|
|
366 first element of the comint-send-queue is the current send entry. If
|
|
|
367 the entry has a nil no-insert flag, insert the results into the
|
|
|
368 process buffer.
|
|
|
369
|
|
|
370 If the send is an interrupt, comint-interrupt-start is funcalled on
|
|
|
371 the output and should return the start of the output of an interrupt.
|
|
|
372
|
|
|
373 comint-prompt-status is called with the old prompt and the last line.
|
|
|
374 It should return 'error if the last line is an error, T if it is a
|
|
|
375 prompt and nil otherwise. It should also update the process status by
|
|
|
376 funcalling comint-update-status.
|
|
|
377
|
|
|
378 If there is a send handler, it is called with \(error-p wait-p message
|
|
|
379 output prompt) and should determine what sort of notification is
|
|
|
380 appropriate and return T if errors should be fixed and NIL otherwise.
|
|
|
381
|
|
|
382 If the prompt is an error, then comint-fix-error will be sent to fix
|
|
|
383 the error.
|
|
|
384
|
|
|
385 When there is a prompt in the output stream, the next send will be
|
|
|
386 dispatched unless the wait flag for the send is a string. If it is a
|
|
|
387 string, then results will be discarded until one matches the string as
|
|
|
388 a regexp.
|
|
|
389
|
|
|
390 Output to the process should only be done through the functions
|
|
|
391 comint-send or comint-default-send, or results will be mixed up."
|
|
|
392 (let* ((inhibit-quit t)
|
|
|
393 (window (selected-window))
|
|
|
394 (comint-original-buffer (prog1 (current-buffer)
|
|
|
395 (set-buffer (process-buffer process))))
|
|
|
396 (match-data (match-data))
|
|
|
397 (send (car comint-send-queue))
|
|
|
398 (no-insert (cdr send))
|
|
|
399 (wait-p (cdr no-insert))
|
|
|
400 (messagep (cdr (cdr wait-p)))
|
|
|
401 (handler (cdr messagep))
|
|
|
402 (running (cdr handler))
|
|
|
403 (old-prompt (cdr running))
|
|
|
404 (line (cdr old-prompt))
|
|
|
405 (result (car (cdr line)))
|
|
|
406 (old-result (car result))
|
|
|
407 (no-insert (car no-insert))
|
|
|
408 (message (car messagep))
|
|
|
409 (wait-p (car wait-p))
|
|
|
410 (sync (stringp wait-p)))
|
|
|
411 (comint-log process output t)
|
|
|
412 ;; Remove leading whitespace
|
|
|
413 (if (and (null old-result)
|
|
|
414 (save-excursion (goto-char (process-mark process)) (bolp))
|
|
|
415 (eq (string-match "[ \t]*\n" output) 0))
|
|
|
416 (setq output (substring output (match-end 0))))
|
|
|
417 (rplaca result (concat old-result output))
|
|
|
418 (while (string-match "\n" (car result) (car line))
|
|
|
419 (rplaca line (match-end 0)))
|
|
|
420 (if (not (or sync no-insert))
|
|
|
421 (progn
|
|
|
422 (comint-insert output)
|
|
|
423 ;; Throw away output if storing in buffer
|
|
|
424 (rplaca result (substring (car result) (car line)))
|
|
|
425 (rplaca line 0)))
|
|
|
426 (if (consp (car running)) ;Waiting for interrupt
|
|
|
427 (let ((split (funcall comint-interrupt-start (car result))))
|
|
|
428 (if split
|
|
|
429 (let ((interrupted (car running)))
|
|
|
430 ;; Store output to previous send
|
|
|
431 (rplaca (comint-send-variables interrupted)
|
|
|
432 (substring (car result) 0 split))
|
|
|
433 (rplaca result (substring (car result) (car line)))
|
|
|
434 (rplaca line 0)
|
|
|
435 (rplaca running t)))))
|
|
|
436 (if (not (consp (car running))) ;Look for prompt
|
|
|
437 (let* ((last (substring (car result) (car line)))
|
|
|
438 (is-prompt
|
|
|
439 (funcall comint-prompt-status (car old-prompt) last)))
|
|
|
440 (if is-prompt
|
|
|
441 (let* ((output
|
|
|
442 (if (or no-insert sync)
|
|
|
443 (funcall comint-output-filter
|
|
|
444 (substring (car result) 0 (car line)))))
|
|
|
445 (handler (car handler))
|
|
|
446 (error (eq is-prompt 'error)))
|
|
|
447 (setq old-result (car result))
|
|
|
448 (rplaca result output)
|
|
|
449 (rplacd result (if error (list last) last))
|
|
|
450 (setq comint-output (car result)
|
|
|
451 comint-errorp
|
|
|
452 (or error
|
|
|
453 (and comint-error-regexp
|
|
|
454 comint-output
|
|
|
455 (string-match comint-error-regexp
|
|
|
456 comint-output))))
|
|
|
457 (unwind-protect
|
|
|
458 (if handler
|
|
|
459 (setq handler
|
|
|
460 (funcall handler comint-errorp wait-p
|
|
|
461 message output last)))
|
|
|
462 (if (and error handler no-insert comint-fix-error)
|
|
|
463 (setq comint-send-queue
|
|
|
464 (cons (list comint-fix-error t nil 'fix
|
|
|
465 "Fixing error" nil
|
|
|
466 nil nil 0 (cons nil nil))
|
|
|
467 ;; We may have aborted
|
|
|
468 (or (cdr comint-send-queue)
|
|
|
469 comint-send-queue))))
|
|
|
470 (if sync
|
|
|
471 (let ((match (string-match wait-p old-result)))
|
|
|
472 (if match
|
|
|
473 (progn
|
|
|
474 (rplaca
|
|
|
475 (cdr (cdr (cdr (cdr (car comint-end-queue)))))
|
|
|
476 "Done")
|
|
|
477 (if (not no-insert)
|
|
|
478 (comint-insert
|
|
|
479 (concat
|
|
|
480 (substring old-result 0 match)
|
|
|
481 (substring old-result (match-end 0)))))
|
|
|
482 (rplaca result (substring old-result
|
|
|
483 match (car line)))
|
|
|
484 (rplaca messagep "Done")
|
|
|
485 (rplaca running nil)
|
|
|
486 (comint-dispatch-send process))))
|
|
|
487 ;; Not waiting
|
|
|
488 (rplaca messagep "Done")
|
|
|
489 (rplaca running nil)
|
|
|
490 (comint-dispatch-send process))))
|
|
|
491 (rplacd result nil))))
|
|
|
492 (store-match-data match-data)
|
|
|
493 (if (or (get-buffer-window comint-original-buffer)
|
|
|
494 (eq (window-buffer (minibuffer-window)) comint-original-buffer))
|
|
|
495 (set-buffer comint-original-buffer))))
|
|
|
496
|
|
|
497 ;;;
|
|
|
498 (defun comint-dispatch-send (process)
|
|
|
499 "Dispatch the next send in PROCESS comint-send-queue, popping the
|
|
|
500 current send if done."
|
|
|
501 (let* ((send (car comint-send-queue))
|
|
|
502 (results (comint-send-results send))
|
|
|
503 (prompt (cdr results)))
|
|
|
504 ;; Never pop the last record
|
|
|
505 (cond ((and (null comint-send-queue) ; Catch a bug.
|
|
|
506 (null comint-end-queue)))
|
|
|
507
|
|
|
508 ((eq comint-send-queue comint-end-queue)
|
|
|
509 (let ((init (car send))
|
|
|
510 (running (comint-send-variables send)))
|
|
|
511 (setq comint-queue-emptied t)
|
|
|
512 ;; Set old prompt to prompt
|
|
|
513 (if prompt
|
|
|
514 (rplaca (cdr (comint-send-variables send))
|
|
|
515 (if (consp prompt) (car prompt) prompt)))
|
|
|
516 (rplaca send nil)
|
|
|
517 (if init
|
|
|
518 (funcall init)
|
|
|
519 (if (stringp (car running))
|
|
|
520 ;; Continue if interrupted. There is no way to
|
|
|
521 ;; sense if the interrupted command actually
|
|
|
522 ;; started, so it is possible that a command will
|
|
|
523 ;; get lost.
|
|
|
524 (progn (funcall comint-update-status
|
|
|
525 (car (cdr (cdr (cdr send)))))
|
|
|
526 (comint-sender process comint-continue)
|
|
|
527 (comint-process-filter process (car running))
|
|
|
528 (rplaca running t))))))
|
|
|
529 (t
|
|
|
530 (if prompt
|
|
|
531 ;; Pop
|
|
|
532 (setq comint-send-queue (cdr comint-send-queue)
|
|
|
533 send (car comint-send-queue))
|
|
|
534 ;; Set prompt to top-level prompt
|
|
|
535 (setq prompt (cdr (comint-send-results (car comint-end-queue)))))
|
|
|
536 (let* ((top-level (eq comint-send-queue comint-end-queue))
|
|
|
537 (string (car send))
|
|
|
538 (no-insert (cdr send))
|
|
|
539 (wait-p (cdr no-insert))
|
|
|
540 (status (cdr wait-p))
|
|
|
541 (message (cdr status))
|
|
|
542 (status (car status))
|
|
|
543 (no-insert (car no-insert))
|
|
|
544 (message (car message))
|
|
|
545 (running (comint-send-variables send)))
|
|
|
546 (if top-level
|
|
|
547 (rplaca send nil)
|
|
|
548 (if (stringp string) (funcall comint-update-status status)))
|
|
|
549 (if (and message (not no-insert) (not (stringp (car wait-p)))
|
|
|
550 (not top-level))
|
|
|
551 ;; Display message on first output
|
|
|
552 (comint-insert
|
|
|
553 (concat comment-start comment-start comment-start
|
|
|
554 message comment-end "\n")))
|
|
|
555 (if (and string (not (stringp string)))
|
|
|
556 ;; Elisp code
|
|
|
557 (progn
|
|
|
558 (rplacd (comint-send-results (car comint-send-queue))
|
|
|
559 (if (consp prompt) (car prompt) prompt))
|
|
|
560 (funcall string)
|
|
|
561 (comint-dispatch-send process))
|
|
|
562 (if (stringp (car running))
|
|
|
563 ;; Continue interrupted send
|
|
|
564 (let ((output (car running)))
|
|
|
565 (if (or top-level (car (comint-send-results send))
|
|
|
566 (not (string-equal output "")))
|
|
|
567 ;; Continue old command
|
|
|
568 (progn
|
|
|
569 (rplaca running t)
|
|
|
570 (funcall comint-update-status status)
|
|
|
571 (comint-sender process comint-continue)
|
|
|
572 (comint-process-filter process output)
|
|
|
573 ;; Send queued default sends
|
|
|
574 (if (and top-level string)
|
|
|
575 (comint-sender process string)))
|
|
|
576 ;; Assume we have to restart the command since
|
|
|
577 ;; there is no output. There is no way to
|
|
|
578 ;; sense whether or not the inferior has
|
|
|
579 ;; started processing the previous send. This
|
|
|
580 ;; is a problem only if the original did start
|
|
|
581 ;; and had side effects.
|
|
|
582 (rplaca running nil)
|
|
|
583 (setq comint-send-queue
|
|
|
584 (cons (list comint-fix-error t nil 'fix
|
|
|
585 "Fixing error" nil
|
|
|
586 nil nil 0 (cons nil nil))
|
|
|
587 comint-send-queue))
|
|
|
588 (comint-dispatch-send process)))
|
|
|
589 (if (not top-level)
|
|
|
590 ;; New send, set old prompt to the prompt of previous
|
|
|
591 (rplaca (cdr (comint-send-variables send))
|
|
|
592 (if (consp prompt) (car prompt) prompt)))
|
|
|
593 (if string
|
|
|
594 (progn
|
|
|
595 (rplaca running t)
|
|
|
596 (comint-sender process string))))))))))
|
|
|
597
|
|
|
598 ;;;
|
|
|
599 (defun comint-interrupt (process send)
|
|
|
600 "Interrupt PROCESS to send SEND if comint-continue is defined and
|
|
|
601 the current send is not waiting. Otherwise, SEND will be the next
|
|
|
602 send."
|
|
|
603 (if (and comint-continue (not (car (cdr (cdr (car comint-send-queue))))))
|
|
|
604 (let* ((current (car comint-send-queue))
|
|
|
605 (interrupt
|
|
|
606 ;; string no-insert wait-p status message handler
|
|
|
607 (list nil t nil 'interrupt "Interrupt" nil
|
|
|
608 ;; running old-prompt line (output . prompt)
|
|
|
609 current nil 0 (cons nil nil))))
|
|
|
610 (setq comint-send-queue (cons interrupt (cons send comint-send-queue)))
|
|
|
611 (funcall comint-update-status 'interrupt)
|
|
|
612 (comint-interrupt-subjob))
|
|
|
613 (if (eq comint-send-queue comint-end-queue)
|
|
|
614 (setq comint-send-queue
|
|
|
615 (cons (car comint-send-queue)
|
|
|
616 (cons send comint-send-queue)))
|
|
|
617 (rplacd comint-send-queue (cons send (cdr comint-send-queue))))))
|
|
|
618
|
|
|
619 ;;;%Interface
|
|
|
620 (defun comint-setup-ipc (&optional force)
|
|
|
621 "Setup for IPC in the current buffer. If called interactively,
|
|
|
622 force comint-send-queue to be initialized."
|
|
|
623 (interactive "p")
|
|
|
624 (make-local-variable 'comint-send-newline)
|
|
|
625 (make-local-variable 'comint-always-scroll)
|
|
|
626 (make-local-variable 'comint-fix-error)
|
|
|
627 (make-local-variable 'comint-continue)
|
|
|
628 (make-local-variable 'comint-interrupt-regexp)
|
|
|
629 (make-local-variable 'comint-error-regexp)
|
|
|
630 (make-local-variable 'comint-output-filter)
|
|
|
631 (make-local-variable 'comint-interrupt-start)
|
|
|
632 (make-local-variable 'comint-handler)
|
|
|
633 (make-local-variable 'comint-update-status)
|
|
|
634 (make-local-variable 'comint-prompt-status)
|
|
|
635 (make-local-variable 'comint-send-queue)
|
|
|
636 (make-local-variable 'comint-end-queue)
|
|
|
637 (make-local-variable 'comint-queue-emptied)
|
|
|
638 (make-local-variable 'comint-output)
|
|
|
639 (make-local-variable 'comint-errorp)
|
|
|
640 (make-local-variable 'comint-status)
|
|
|
641 (make-local-variable 'comint-aborting)
|
|
|
642 (if (or force (not comint-send-queue))
|
|
|
643 (setq comint-send-queue
|
|
|
644 (list (list nil nil nil 'run "Top Level"
|
|
|
645 nil t nil 0 (cons nil nil)))
|
|
|
646 comint-end-queue comint-send-queue))
|
|
|
647 (let ((process (get-buffer-process (current-buffer))))
|
|
|
648 (set-process-filter process 'comint-process-filter)
|
|
|
649 (set-process-sentinel process 'comint-process-sentinel))
|
|
|
650 (setq mode-line-process 'comint-status))
|
|
|
651
|
|
|
652 ;;;%%Input
|
|
|
653 (defun comint-send (process string
|
|
|
654 &optional
|
|
|
655 no-insert
|
|
|
656 wait
|
|
|
657 status
|
|
|
658 message
|
|
|
659 handler
|
|
|
660 after)
|
|
|
661 "Do a send to PROCESS of STRING. Optionally specify NO-INSERT,
|
|
|
662 WAIT, STATUS, MESSAGE, HANDLER and AFTER. Without optional arguments,
|
|
|
663 this is just like process-send-string. If STRING is not a string,
|
|
|
664 then it is assumed to be an elisp function and will be called when
|
|
|
665 encountered in the send queue. The send will be the next one if WAIT,
|
|
|
666 after the last send if AFTER, otherwise it will be put at the end of
|
|
|
667 the queue. If WAIT is non-NIL or on the first send to a busy inferior,
|
|
|
668 the inferior will be interrupted if possible, see comint-interrupt for
|
|
|
669 more information. Once the send is sent, the process status will be
|
|
|
670 STATUS or 'run. Output of the send will be inserted into the process
|
|
|
671 buffer unless NO-INSERT. This function returns a list of \(result .
|
|
|
672 prompt). If WAIT is a string, output will be inserted until one
|
|
|
673 matches the string as a regexp. If WAIT is T, then PROMPT will have
|
|
|
674 the prompt when finished and RESULT will have the output. If PROMPT
|
|
|
675 is a list, then there was an error. If WAIT is not T, then the list
|
|
|
676 returned will change when the send has been sent and is finished. If
|
|
|
677 HANDLER is nil it will be set to comint-handler. If it is T, errors
|
|
|
678 will be ignored. When a send is finished, it calls handler with
|
|
|
679 \(error-p WAIT MESSAGE output prompt) which decides what to do with
|
|
|
680 the output.
|
|
|
681
|
|
|
682 VARIABLES:
|
|
|
683
|
|
|
684 comint-always-scroll will cause all process output to be visible.
|
|
|
685
|
|
|
686 comint-fix-error is the string used to fix errors.
|
|
|
687
|
|
|
688 comint-continue is the string used to continue after an interrupt.
|
|
|
689
|
|
|
690 comint-interrupt-regexp is the default regexp to use in finding the
|
|
|
691 start of the interrupt text.
|
|
|
692
|
|
|
693 comint-error-regexp will set comint-errorp if found in the process output.
|
|
|
694
|
|
|
695 FUNCTIONS: Each of the functions in these variables is called with
|
|
|
696 the buffer set to the appropriate process buffer and
|
|
|
697 comint-original-buffer bound to the buffer current when the process
|
|
|
698 filter was called.
|
|
|
699
|
|
|
700 comint-update-status is a function \(status) that is called each time
|
|
|
701 the process status changes.
|
|
|
702
|
|
|
703 comint-prompt-status is called with the old prompt and the last line.
|
|
|
704 It should return 'error if the last line is an error, T if it is a
|
|
|
705 prompt and nil otherwise. It should also update the process status by
|
|
|
706 funcalling comint-update-status.
|
|
|
707
|
|
|
708 comint-output-filter is a function \(output) for sends with NO-INSERT.
|
|
|
709 It should return the output string.
|
|
|
710
|
|
|
711 comint-interrupt-start is a function \(output) that returns the start
|
|
|
712 of the interrupt text in output using comint-interrupt-regexp to find it."
|
|
|
713 (save-excursion
|
|
|
714 (set-buffer (process-buffer process))
|
|
|
715 (let* ((inhibit-quit t)
|
|
|
716 (send (list string
|
|
|
717 no-insert
|
|
|
718 wait
|
|
|
719 (or status 'run)
|
|
|
720 message
|
|
|
721 (if (eq handler t) nil (or handler comint-handler))
|
|
|
722 ;; running, old-prompt, line
|
|
|
723 nil nil 0
|
|
|
724 ;; (output . prompt)
|
|
|
725 (cons nil nil)))
|
|
|
726 (pointer (comint-send-results send))
|
|
|
727 (top-level (eq comint-send-queue comint-end-queue))
|
|
|
728 (end (car comint-end-queue))
|
|
|
729 (current (car comint-send-queue))
|
|
|
730 (prompt (cdr (comint-send-results current)))
|
|
|
731 (ok nil))
|
|
|
732 (setq comint-aborting nil)
|
|
|
733 (if (and top-level (or (stringp wait) prompt))
|
|
|
734 (progn
|
|
|
735 (setq comint-send-queue (cons send comint-send-queue))
|
|
|
736 (comint-dispatch-send process))
|
|
|
737 (if (or (and wait (not after) (not prompt)) top-level)
|
|
|
738 (comint-interrupt process send)
|
|
|
739 (let ((looking t)
|
|
|
740 (next comint-send-queue))
|
|
|
741 (if after
|
|
|
742 (while (and looking next)
|
|
|
743 (if (eq (car next) comint-last-send)
|
|
|
744 (progn
|
|
|
745 (rplacd next (cons send (cdr next)))
|
|
|
746 (setq looking nil)))
|
|
|
747 (setq next (cdr next))))
|
|
|
748 (if looking
|
|
|
749 (progn
|
|
|
750 (rplaca comint-end-queue send)
|
|
|
751 (setq comint-end-queue
|
|
|
752 (rplacd comint-end-queue (cons end nil))))))))
|
|
|
753 (setq comint-last-send send)
|
|
|
754 (unwind-protect
|
|
|
755 (let ((inhibit-quit nil))
|
|
|
756 (if (eq wait t)
|
|
|
757 (while (not (cdr pointer))
|
|
|
758 (accept-process-output)
|
|
|
759 (sit-for 0)))
|
|
|
760 (setq ok pointer))
|
|
|
761 (if (not ok)
|
|
|
762 (if (eq send (car comint-send-queue))
|
|
|
763 (let ((interrupt
|
|
|
764 ;; string no-insert wait status message handler
|
|
|
765 (list nil t nil 'interrupt "Interrupt" nil
|
|
|
766 ;; running old-prompt line (output . prompt)
|
|
|
767 send (car (cdr (comint-send-variables send)))
|
|
|
768 nil (cons nil nil))))
|
|
|
769 (setq comint-send-queue
|
|
|
770 (cons interrupt (cdr comint-send-queue)))
|
|
|
771 (comint-interrupt-subjob))
|
|
|
772 (setq comint-send-queue (delq send comint-send-queue))))))))
|
|
|
773
|
|
|
774 ;;;
|
|
|
775 (defun comint-send-code (process code)
|
|
|
776 "Execute after the previous send in PROCESS queue CODE. You do not
|
|
|
777 want to execute synchronous sends in the code or it will lock up. "
|
|
|
778 (comint-send process code nil nil nil nil nil t))
|
|
|
779
|
|
|
780 ;;;
|
|
|
781 (defun comint-default-send (process string)
|
|
|
782 "Send to PROCESS top-level, STRING."
|
|
|
783 (save-excursion
|
|
|
784 (set-buffer (process-buffer process))
|
|
|
785 (let* ((top (car comint-end-queue))
|
|
|
786 (old (car top)))
|
|
|
787 (rplaca (cdr (cdr (cdr (cdr (car comint-end-queue))))) string)
|
|
|
788 (if (eq comint-send-queue comint-end-queue)
|
|
|
789 (progn (funcall comint-update-status 'run)
|
|
|
790 (rplaca (comint-send-variables (car comint-send-queue)) t)
|
|
|
791 (rplacd (comint-send-results (car comint-send-queue)) nil)
|
|
|
792 (comint-sender process string))
|
|
|
793 (rplaca top
|
|
|
794 (if old
|
|
|
795 (concat old (if comint-send-newline "\n") string)
|
|
|
796 string))))))
|
|
|
797
|
|
|
798 ;;;
|
|
|
799 (defun comint-sync (process start start-regexp end end-regexp)
|
|
|
800 "Synchronize with PROCESS output stream. START will be sent with
|
|
|
801 each prompt received until START-REGEXP shows up in the stream. Then
|
|
|
802 END will be sent and all output will be discarded until END-REGEXP
|
|
|
803 shows up in the output stream."
|
|
|
804 (comint-send
|
|
|
805 process
|
|
|
806 start
|
|
|
807 nil start-regexp 'sync "Start sync"
|
|
|
808 (function (lambda (error-p wait message output prompt)
|
|
|
809 (if (not (string-match wait output))
|
|
|
810 (comint-sender
|
|
|
811 (get-buffer-process (current-buffer))
|
|
|
812 (car (car comint-send-queue))))
|
|
|
813 nil)))
|
|
|
814 (comint-send
|
|
|
815 process
|
|
|
816 end
|
|
|
817 t end-regexp 'sync "End sync"
|
|
|
818 (function (lambda (&rest args) nil))))
|
|
|
819
|
|
|
820 ;;;
|
|
|
821 (defun comint-abort-sends (&optional process)
|
|
|
822 "Abort all of the pending sends for optional PROCESS and show their
|
|
|
823 messages in *Aborted Commands*."
|
|
|
824 (interactive)
|
|
|
825 (save-excursion
|
|
|
826 (setq process (or process (get-buffer-process (current-buffer))))
|
|
|
827 (set-buffer (process-buffer process))
|
|
|
828 (setq comint-aborting t)
|
|
|
829 (if (not (eq comint-send-queue comint-end-queue))
|
|
|
830 (let* ((inhibit-quit t)
|
|
|
831 (send (car comint-send-queue))
|
|
|
832 (vars (comint-send-variables send))
|
|
|
833 (pointer comint-send-queue)
|
|
|
834 (new nil)
|
|
|
835 (interrupt (and (car vars)
|
|
|
836 (not (cdr (comint-send-results send))))))
|
|
|
837 (if interrupt
|
|
|
838 (progn ;Sent, but no prompt
|
|
|
839 (if (consp (car vars))
|
|
|
840 (progn (setq new (list send))
|
|
|
841 (rplaca (cdr (cdr (cdr (cdr (cdr send)))))
|
|
|
842 (function (lambda (&rest args) t))))
|
|
|
843 (setq new
|
|
|
844 (list
|
|
|
845 (list nil t nil 'interrupt "Interrupt"
|
|
|
846 (function (lambda (&rest args) t))
|
|
|
847 send (car (cdr (comint-send-variables send)))
|
|
|
848 nil (cons nil nil))))
|
|
|
849 (comint-interrupt-subjob)))) ;Already interrupting
|
|
|
850 (save-excursion
|
|
|
851 (set-buffer (get-buffer-create "*Aborted Commands*"))
|
|
|
852 (delete-region (point-min) (point-max)))
|
|
|
853 (while (not (eq pointer comint-end-queue))
|
|
|
854 (let ((send (car pointer)))
|
|
|
855 (if (car (cdr (cdr (cdr (cdr send))))) ;Message
|
|
|
856 (save-excursion
|
|
|
857 (set-buffer "*Aborted Commands*")
|
|
|
858 (insert (comint-send-description send))
|
|
|
859 (insert "\n\n")))
|
|
|
860 (if (and comint-fix-error
|
|
|
861 (stringp (car (comint-send-variables send))))
|
|
|
862 ;; Interrupted
|
|
|
863 (setq new (cons
|
|
|
864 (list comint-fix-error t nil 'fix
|
|
|
865 "Fixing error" nil
|
|
|
866 nil nil 0 (cons nil nil))
|
|
|
867 new)))
|
|
|
868 (setq pointer (cdr pointer))))
|
|
|
869 (bury-buffer "*Aborted Commands*")
|
|
|
870 (rplaca (car comint-end-queue) nil)
|
|
|
871 (setq comint-send-queue
|
|
|
872 (reverse (cons (car comint-end-queue) new))
|
|
|
873 comint-end-queue
|
|
|
874 (let ((pointer comint-send-queue))
|
|
|
875 (while (cdr pointer)
|
|
|
876 (setq pointer (cdr pointer)))
|
|
|
877 pointer))
|
|
|
878 (run-hooks 'comint-abort-hook)
|
|
|
879 (if (not interrupt) (comint-dispatch-send process))))))
|
|
|
880
|
|
|
881 ;;;
|
|
|
882 (defun comint-current-send (showp)
|
|
|
883 "Show the message of the current send in the minibuffer."
|
|
|
884 (interactive "P")
|
|
|
885 (if showp
|
|
|
886 (with-output-to-temp-buffer comint-output-buffer
|
|
|
887 (let ((send comint-send-queue))
|
|
|
888 (save-excursion
|
|
|
889 (set-buffer comint-output-buffer)
|
|
|
890 (insert "Pending commands:\n")
|
|
|
891 (while send
|
|
|
892 (let ((message (car (cdr (cdr (cdr (cdr (car send))))))))
|
|
|
893 (if message (insert (concat message "\n"))))
|
|
|
894 (setq send (cdr send)))))))
|
|
|
895 (message
|
|
|
896 (concat "Command: "
|
|
|
897 (or (comint-send-description (car comint-send-queue))
|
|
|
898 "Unknown"))))
|
|
|
899
|
|
|
900
|
|
|
901 ;;;
|
|
|
902 (defun comint-display-output (text &optional buffer)
|
|
|
903 "Put TEXT in optional BUFFER and show it in a small temporary window."
|
|
|
904 (setq buffer (or buffer comint-output-buffer))
|
|
|
905 (with-output-to-temp-buffer buffer
|
|
|
906 (save-excursion
|
|
|
907 (set-buffer buffer)
|
|
|
908 (insert text)
|
|
|
909 (set-buffer-modified-p nil)))
|
|
|
910 text)
|
|
|
911 ;; Perhaps this should use ilisp-display-output.
|
|
|
912
|
|
|
913 ;;;
|
|
|
914 (defun comint-display-error (text)
|
|
|
915 "Put TEXT in the comint-error-buffer and display it."
|
|
|
916 (comint-display-output text comint-error-buffer))
|
|
|
917
|
|
|
918 (provide 'comint-ipc)
|
