|
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 ;;;
|
|
4
|
11 ;;; Send mail to ilisp@naggum.no if you have problems.
|
|
0
|
12 ;;;
|
|
4
|
13 ;;; Send mail to ilisp-request@naggum.no if you want to be on the
|
|
0
|
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
|
|
4
|
189 ;;; v5.7b Removed by suggestion of erik@naggum.no (Erik Naggum).
|
|
0
|
190
|
|
4
|
191 ;;; (defun comint-send-string (proc str)
|
|
|
192 ;;; "Send PROCESS the contents of STRING as input.
|
|
|
193 ;;; This is equivalent to process-send-string, except that long input strings
|
|
|
194 ;;; are broken up into chunks of size comint-input-chunk-size. Processes
|
|
|
195 ;;; are given a chance to output between chunks. This can help prevent
|
|
|
196 ;;; processes from hanging when you send them long inputs on some OS's."
|
|
|
197 ;;; (comint-log proc str)
|
|
|
198 ;;; (let* ((len (length str))
|
|
|
199 ;;; (i (min len comint-input-chunk-size)))
|
|
|
200 ;;; (process-send-string proc (substring str 0 i))
|
|
|
201 ;;; (while (< i len)
|
|
|
202 ;;; (let ((next-i (+ i comint-input-chunk-size)))
|
|
|
203 ;;; (accept-process-output)
|
|
|
204 ;;; (process-send-string proc (substring str i (min len next-i)))
|
|
|
205 ;;; (setq i next-i)))))
|
|
|
206
|
|
|
207 ;;; v5.7b See above
|
|
0
|
208 (defun comint-sender (process string)
|
|
|
209 "Send to PROCESS STRING with newline if comint-send-newline."
|
|
4
|
210 ;; (comint-send-string process string)
|
|
|
211 (process-send-string process string)
|
|
0
|
212 (if comint-send-newline
|
|
|
213 (progn
|
|
|
214 (comint-log process "\n")
|
|
|
215 (process-send-string process "\n"))))
|
|
|
216
|
|
|
217 ;;;
|
|
|
218 (defun comint-interrupt-subjob ()
|
|
|
219 "Interrupt the current subjob."
|
|
|
220 (interactive)
|
|
|
221 (comint-log (get-buffer-process (current-buffer)) "")
|
|
|
222 (interrupt-process nil comint-ptyp))
|
|
|
223
|
|
|
224 ;;;
|
|
|
225 (defun comint-send-variables (send)
|
|
|
226 "Return a pointer to the start of the variables for SEND. It
|
|
|
227 returns \(running old-prompt line \(output . prompt))."
|
|
|
228 (cdr (cdr (cdr (cdr (cdr (cdr send)))))))
|
|
|
229
|
|
|
230 ;;;
|
|
|
231 (defun comint-send-results (send)
|
|
|
232 "Return the results of SEND which are \(output . prompt). If there is
|
|
|
233 an error, the prompt will be a list."
|
|
|
234 (car (cdr (cdr (cdr (comint-send-variables send))))))
|
|
|
235
|
|
|
236 ;;;
|
|
|
237 (defun comint-send-description (send)
|
|
|
238 "Return a description of SEND."
|
|
|
239 (let* ((status (cdr (cdr (cdr send)))))
|
|
|
240 (or (car (cdr status)) ;Message
|
|
|
241 (and (stringp (car send)) (car send)) ;String
|
|
|
242 (and (car status) (symbol-name (car status))))))
|
|
|
243
|
|
|
244 ;;;
|
|
|
245 (defun comint-interrupted ()
|
|
|
246 "Return T if there is an interrupted send."
|
|
|
247 (let ((send comint-send-queue)
|
|
|
248 (done nil))
|
|
|
249 (while (and send (not done))
|
|
|
250 (if (stringp (car (comint-send-variables (car send))))
|
|
|
251 (setq done t)
|
|
|
252 (setq send (cdr send))))
|
|
|
253 done))
|
|
|
254
|
|
|
255
|
|
|
256 ;;;%Default hooks
|
|
|
257 (defun comint-process-sentinel (process status)
|
|
|
258 "Update PROCESS STATUS by funcalling comint-update-status."
|
|
|
259 (setq status (process-status process))
|
|
|
260 (save-excursion
|
|
|
261 (if (buffer-name (process-buffer process))
|
|
|
262 (set-buffer (process-buffer process)))
|
|
|
263 (funcall comint-update-status status)))
|
|
|
264
|
|
|
265 ;;;
|
|
|
266 (defun comint-interrupt-start (output)
|
|
|
267 "Return the start of comint-interrupt-regexp in OUTPUT."
|
|
|
268 (if (and comint-interrupt-regexp
|
|
|
269 (string-match comint-interrupt-regexp output))
|
|
|
270 (match-beginning 0)))
|
|
|
271
|
|
|
272 ;;;
|
|
|
273 (defun comint-update-status (status)
|
|
|
274 "Update the process STATUS of the current buffer."
|
|
|
275 (setq comint-status (format " :%s" status))
|
|
|
276 (if comint-show-status
|
|
|
277 (progn
|
|
|
278 (save-excursion (set-buffer (other-buffer)))
|
|
|
279 (sit-for 0))))
|
|
|
280
|
|
|
281 ;;;
|
|
|
282 (defun comint-prompt-status (old line &optional equal)
|
|
|
283 "Called by comint-process filter with OLD and LINE, return 'error if
|
|
|
284 LINE is an error, T if it is a prompt as determined by
|
|
|
285 comint-prompt-regexp or nil otherwise. Also set the status
|
|
|
286 appropriately by funcalling comint-update-status. If specified EQUAL
|
|
|
287 will be called with old and line and should return T if line is not an
|
|
|
288 error. OLD will be nil for the first prompt."
|
|
|
289 (if (string-match comint-prompt-regexp line)
|
|
|
290 (let ((error (or (if equal
|
|
|
291 (funcall equal old line)
|
|
|
292 (or (null old) (string-equal old line)))
|
|
|
293 'error)))
|
|
|
294 (funcall comint-update-status (if (eq error 'error) error 'ready))
|
|
|
295 error)
|
|
|
296 nil))
|
|
|
297
|
|
|
298 ;;;
|
|
|
299 (defun comint-insert (output)
|
|
|
300 "Insert process OUTPUT into the current buffer."
|
|
|
301 (if output
|
|
|
302 (let* ((buffer (current-buffer))
|
|
|
303 (process (get-buffer-process buffer))
|
|
|
304 (mark (process-mark process))
|
|
|
305 (window (selected-window))
|
|
|
306 (at-end nil))
|
|
|
307 (if (eq (window-buffer window) buffer)
|
|
|
308 (setq at-end (= (point) mark))
|
|
|
309 (setq window (get-buffer-window buffer)))
|
|
|
310 (save-excursion
|
|
|
311 (goto-char mark)
|
|
|
312 (insert output)
|
|
|
313 (set-marker mark (point)))
|
|
|
314 (if window
|
|
|
315 (progn
|
|
|
316 (if (or at-end comint-always-scroll) (goto-char mark))
|
|
|
317 (if (not (pos-visible-in-window-p (point) window))
|
|
|
318 (let ((original (selected-window)))
|
|
|
319 (save-excursion
|
|
|
320 (select-window window)
|
|
|
321 (recenter '(center))
|
|
|
322 (select-window original)))))))))
|
|
|
323
|
|
|
324 ;;;
|
|
|
325 (defun comint-handle-error (output prompt keys &optional delay)
|
|
|
326 "Handle an error by beeping, displaying OUTPUT and then waiting for
|
|
|
327 the user to pause. Once there is pause, PROMPT until one of the
|
|
|
328 characters in KEYS is typed. If optional DELAY is specified, it is
|
|
|
329 the number of seconds that the user must pause. The key found will be
|
|
|
330 returned."
|
|
|
331 (save-excursion
|
|
|
332 (setq delay (or delay 1))
|
|
|
333 (beep t)
|
|
|
334 (comint-display-error output)
|
|
|
335 (set-buffer comint-original-buffer)
|
|
|
336 (while (not (sit-for delay nil))
|
|
|
337 (execute-kbd-macro (read-key-sequence nil)))
|
|
|
338 (if (not (get-buffer-window (get-buffer comint-error-buffer)))
|
|
|
339 (comint-display-error output))
|
|
|
340 (let ((cursor-in-echo-area t)
|
|
|
341 (echo-keystrokes 0)
|
|
|
342 char)
|
|
|
343 (while (progn (message prompt)
|
|
|
344 (not (memq (setq char (downcase (read-char))) keys)))
|
|
|
345 (if (= char ? )
|
|
|
346 (ilisp-scroll-output)
|
|
|
347 (setq quit-flag nil)
|
|
|
348 (beep)))
|
|
|
349 char)))
|
|
|
350
|
|
|
351 ;;;
|
|
|
352 (defun comint-error-popup (error wait-p message output prompt)
|
|
|
353 "If there is an ERROR pop up a window with MESSAGE and OUTPUT.
|
|
|
354 Nothing is done with PROMPT or WAIT-P."
|
|
|
355 (if error
|
|
|
356 (save-excursion
|
|
|
357 (with-output-to-temp-buffer comint-output-buffer
|
|
|
358 (set-buffer comint-output-buffer)
|
|
|
359 (if message (insert message))
|
|
|
360 (insert ?\n)
|
|
|
361 (insert output)
|
|
|
362 (beep t))))
|
|
|
363 t)
|
|
|
364
|
|
|
365 ;;;
|
|
|
366 (defun comint-process-filter (process output)
|
|
|
367 "Filter PROCESS OUTPUT. See comint-send for more information. The
|
|
|
368 first element of the comint-send-queue is the current send entry. If
|
|
|
369 the entry has a nil no-insert flag, insert the results into the
|
|
|
370 process buffer.
|
|
|
371
|
|
|
372 If the send is an interrupt, comint-interrupt-start is funcalled on
|
|
|
373 the output and should return the start of the output of an interrupt.
|
|
|
374
|
|
|
375 comint-prompt-status is called with the old prompt and the last line.
|
|
|
376 It should return 'error if the last line is an error, T if it is a
|
|
|
377 prompt and nil otherwise. It should also update the process status by
|
|
|
378 funcalling comint-update-status.
|
|
|
379
|
|
|
380 If there is a send handler, it is called with \(error-p wait-p message
|
|
|
381 output prompt) and should determine what sort of notification is
|
|
|
382 appropriate and return T if errors should be fixed and NIL otherwise.
|
|
|
383
|
|
|
384 If the prompt is an error, then comint-fix-error will be sent to fix
|
|
|
385 the error.
|
|
|
386
|
|
|
387 When there is a prompt in the output stream, the next send will be
|
|
|
388 dispatched unless the wait flag for the send is a string. If it is a
|
|
|
389 string, then results will be discarded until one matches the string as
|
|
|
390 a regexp.
|
|
|
391
|
|
|
392 Output to the process should only be done through the functions
|
|
|
393 comint-send or comint-default-send, or results will be mixed up."
|
|
|
394 (let* ((inhibit-quit t)
|
|
|
395 (window (selected-window))
|
|
|
396 (comint-original-buffer (prog1 (current-buffer)
|
|
|
397 (set-buffer (process-buffer process))))
|
|
|
398 (match-data (match-data))
|
|
|
399 (send (car comint-send-queue))
|
|
|
400 (no-insert (cdr send))
|
|
|
401 (wait-p (cdr no-insert))
|
|
|
402 (messagep (cdr (cdr wait-p)))
|
|
|
403 (handler (cdr messagep))
|
|
|
404 (running (cdr handler))
|
|
|
405 (old-prompt (cdr running))
|
|
|
406 (line (cdr old-prompt))
|
|
|
407 (result (car (cdr line)))
|
|
|
408 (old-result (car result))
|
|
|
409 (no-insert (car no-insert))
|
|
|
410 (message (car messagep))
|
|
|
411 (wait-p (car wait-p))
|
|
|
412 (sync (stringp wait-p)))
|
|
|
413 (comint-log process output t)
|
|
|
414 ;; Remove leading whitespace
|
|
|
415 (if (and (null old-result)
|
|
|
416 (save-excursion (goto-char (process-mark process)) (bolp))
|
|
|
417 (eq (string-match "[ \t]*\n" output) 0))
|
|
|
418 (setq output (substring output (match-end 0))))
|
|
|
419 (rplaca result (concat old-result output))
|
|
|
420 (while (string-match "\n" (car result) (car line))
|
|
|
421 (rplaca line (match-end 0)))
|
|
|
422 (if (not (or sync no-insert))
|
|
|
423 (progn
|
|
|
424 (comint-insert output)
|
|
|
425 ;; Throw away output if storing in buffer
|
|
|
426 (rplaca result (substring (car result) (car line)))
|
|
|
427 (rplaca line 0)))
|
|
|
428 (if (consp (car running)) ;Waiting for interrupt
|
|
|
429 (let ((split (funcall comint-interrupt-start (car result))))
|
|
|
430 (if split
|
|
|
431 (let ((interrupted (car running)))
|
|
|
432 ;; Store output to previous send
|
|
|
433 (rplaca (comint-send-variables interrupted)
|
|
|
434 (substring (car result) 0 split))
|
|
|
435 (rplaca result (substring (car result) (car line)))
|
|
|
436 (rplaca line 0)
|
|
|
437 (rplaca running t)))))
|
|
|
438 (if (not (consp (car running))) ;Look for prompt
|
|
|
439 (let* ((last (substring (car result) (car line)))
|
|
|
440 (is-prompt
|
|
|
441 (funcall comint-prompt-status (car old-prompt) last)))
|
|
|
442 (if is-prompt
|
|
|
443 (let* ((output
|
|
|
444 (if (or no-insert sync)
|
|
|
445 (funcall comint-output-filter
|
|
|
446 (substring (car result) 0 (car line)))))
|
|
|
447 (handler (car handler))
|
|
|
448 (error (eq is-prompt 'error)))
|
|
|
449 (setq old-result (car result))
|
|
|
450 (rplaca result output)
|
|
|
451 (rplacd result (if error (list last) last))
|
|
|
452 (setq comint-output (car result)
|
|
|
453 comint-errorp
|
|
|
454 (or error
|
|
|
455 (and comint-error-regexp
|
|
|
456 comint-output
|
|
|
457 (string-match comint-error-regexp
|
|
|
458 comint-output))))
|
|
|
459 (unwind-protect
|
|
4
|
460 ;; (if handler
|
|
|
461 ;; (setq handler
|
|
|
462 ;; (funcall handler comint-errorp wait-p
|
|
|
463 ;; message output last)))
|
|
|
464
|
|
|
465 ;; v5.7b Patch suggested by fujieda@jaist.ac.jp
|
|
|
466 ;; (Kazuhiro Fujieda). Here is his comment.
|
|
|
467
|
|
|
468 ;; "When the 'handler' is called, the current
|
|
|
469 ;; buffer may be changed. 'comint-process-filter'
|
|
|
470 ;; accesses some buffer-local variables, for
|
|
|
471 ;; example 'comint-send-queue' and
|
|
|
472 ;; 'comint-end-queue'. If the current buffer is
|
|
|
473 ;; changed in the 'handler', the entities of
|
|
|
474 ;; these buffer-local variables is replaced, and
|
|
|
475 ;; corrupt successive behaviors."
|
|
|
476
|
|
|
477 ;; The code hereafter fixes the problem.
|
|
|
478
|
|
0
|
479 (if handler
|
|
4
|
480 (save-excursion
|
|
|
481 (setq handler
|
|
|
482 (funcall handler comint-errorp wait-p
|
|
|
483 message output last))))
|
|
|
484
|
|
0
|
485 (if (and error handler no-insert comint-fix-error)
|
|
|
486 (setq comint-send-queue
|
|
|
487 (cons (list comint-fix-error t nil 'fix
|
|
|
488 "Fixing error" nil
|
|
|
489 nil nil 0 (cons nil nil))
|
|
|
490 ;; We may have aborted
|
|
|
491 (or (cdr comint-send-queue)
|
|
|
492 comint-send-queue))))
|
|
|
493 (if sync
|
|
|
494 (let ((match (string-match wait-p old-result)))
|
|
|
495 (if match
|
|
|
496 (progn
|
|
|
497 (rplaca
|
|
|
498 (cdr (cdr (cdr (cdr (car comint-end-queue)))))
|
|
|
499 "Done")
|
|
|
500 (if (not no-insert)
|
|
|
501 (comint-insert
|
|
|
502 (concat
|
|
|
503 (substring old-result 0 match)
|
|
|
504 (substring old-result (match-end 0)))))
|
|
|
505 (rplaca result (substring old-result
|
|
|
506 match (car line)))
|
|
|
507 (rplaca messagep "Done")
|
|
|
508 (rplaca running nil)
|
|
|
509 (comint-dispatch-send process))))
|
|
|
510 ;; Not waiting
|
|
|
511 (rplaca messagep "Done")
|
|
|
512 (rplaca running nil)
|
|
|
513 (comint-dispatch-send process))))
|
|
|
514 (rplacd result nil))))
|
|
|
515 (store-match-data match-data)
|
|
|
516 (if (or (get-buffer-window comint-original-buffer)
|
|
|
517 (eq (window-buffer (minibuffer-window)) comint-original-buffer))
|
|
|
518 (set-buffer comint-original-buffer))))
|
|
|
519
|
|
|
520 ;;;
|
|
|
521 (defun comint-dispatch-send (process)
|
|
|
522 "Dispatch the next send in PROCESS comint-send-queue, popping the
|
|
|
523 current send if done."
|
|
|
524 (let* ((send (car comint-send-queue))
|
|
|
525 (results (comint-send-results send))
|
|
|
526 (prompt (cdr results)))
|
|
|
527 ;; Never pop the last record
|
|
|
528 (cond ((and (null comint-send-queue) ; Catch a bug.
|
|
|
529 (null comint-end-queue)))
|
|
|
530
|
|
|
531 ((eq comint-send-queue comint-end-queue)
|
|
|
532 (let ((init (car send))
|
|
|
533 (running (comint-send-variables send)))
|
|
|
534 (setq comint-queue-emptied t)
|
|
|
535 ;; Set old prompt to prompt
|
|
|
536 (if prompt
|
|
|
537 (rplaca (cdr (comint-send-variables send))
|
|
|
538 (if (consp prompt) (car prompt) prompt)))
|
|
|
539 (rplaca send nil)
|
|
|
540 (if init
|
|
|
541 (funcall init)
|
|
|
542 (if (stringp (car running))
|
|
|
543 ;; Continue if interrupted. There is no way to
|
|
|
544 ;; sense if the interrupted command actually
|
|
|
545 ;; started, so it is possible that a command will
|
|
|
546 ;; get lost.
|
|
|
547 (progn (funcall comint-update-status
|
|
|
548 (car (cdr (cdr (cdr send)))))
|
|
|
549 (comint-sender process comint-continue)
|
|
|
550 (comint-process-filter process (car running))
|
|
|
551 (rplaca running t))))))
|
|
|
552 (t
|
|
|
553 (if prompt
|
|
|
554 ;; Pop
|
|
|
555 (setq comint-send-queue (cdr comint-send-queue)
|
|
|
556 send (car comint-send-queue))
|
|
|
557 ;; Set prompt to top-level prompt
|
|
|
558 (setq prompt (cdr (comint-send-results (car comint-end-queue)))))
|
|
|
559 (let* ((top-level (eq comint-send-queue comint-end-queue))
|
|
|
560 (string (car send))
|
|
|
561 (no-insert (cdr send))
|
|
|
562 (wait-p (cdr no-insert))
|
|
|
563 (status (cdr wait-p))
|
|
|
564 (message (cdr status))
|
|
|
565 (status (car status))
|
|
|
566 (no-insert (car no-insert))
|
|
|
567 (message (car message))
|
|
|
568 (running (comint-send-variables send)))
|
|
|
569 (if top-level
|
|
|
570 (rplaca send nil)
|
|
|
571 (if (stringp string) (funcall comint-update-status status)))
|
|
|
572 (if (and message (not no-insert) (not (stringp (car wait-p)))
|
|
|
573 (not top-level))
|
|
|
574 ;; Display message on first output
|
|
|
575 (comint-insert
|
|
|
576 (concat comment-start comment-start comment-start
|
|
|
577 message comment-end "\n")))
|
|
|
578 (if (and string (not (stringp string)))
|
|
|
579 ;; Elisp code
|
|
|
580 (progn
|
|
|
581 (rplacd (comint-send-results (car comint-send-queue))
|
|
|
582 (if (consp prompt) (car prompt) prompt))
|
|
|
583 (funcall string)
|
|
|
584 (comint-dispatch-send process))
|
|
|
585 (if (stringp (car running))
|
|
|
586 ;; Continue interrupted send
|
|
|
587 (let ((output (car running)))
|
|
|
588 (if (or top-level (car (comint-send-results send))
|
|
|
589 (not (string-equal output "")))
|
|
|
590 ;; Continue old command
|
|
|
591 (progn
|
|
|
592 (rplaca running t)
|
|
|
593 (funcall comint-update-status status)
|
|
|
594 (comint-sender process comint-continue)
|
|
|
595 (comint-process-filter process output)
|
|
|
596 ;; Send queued default sends
|
|
|
597 (if (and top-level string)
|
|
|
598 (comint-sender process string)))
|
|
|
599 ;; Assume we have to restart the command since
|
|
|
600 ;; there is no output. There is no way to
|
|
|
601 ;; sense whether or not the inferior has
|
|
|
602 ;; started processing the previous send. This
|
|
|
603 ;; is a problem only if the original did start
|
|
|
604 ;; and had side effects.
|
|
|
605 (rplaca running nil)
|
|
|
606 (setq comint-send-queue
|
|
|
607 (cons (list comint-fix-error t nil 'fix
|
|
|
608 "Fixing error" nil
|
|
|
609 nil nil 0 (cons nil nil))
|
|
|
610 comint-send-queue))
|
|
|
611 (comint-dispatch-send process)))
|
|
|
612 (if (not top-level)
|
|
|
613 ;; New send, set old prompt to the prompt of previous
|
|
|
614 (rplaca (cdr (comint-send-variables send))
|
|
|
615 (if (consp prompt) (car prompt) prompt)))
|
|
|
616 (if string
|
|
|
617 (progn
|
|
|
618 (rplaca running t)
|
|
|
619 (comint-sender process string))))))))))
|
|
|
620
|
|
|
621 ;;;
|
|
|
622 (defun comint-interrupt (process send)
|
|
|
623 "Interrupt PROCESS to send SEND if comint-continue is defined and
|
|
|
624 the current send is not waiting. Otherwise, SEND will be the next
|
|
|
625 send."
|
|
|
626 (if (and comint-continue (not (car (cdr (cdr (car comint-send-queue))))))
|
|
|
627 (let* ((current (car comint-send-queue))
|
|
|
628 (interrupt
|
|
|
629 ;; string no-insert wait-p status message handler
|
|
|
630 (list nil t nil 'interrupt "Interrupt" nil
|
|
|
631 ;; running old-prompt line (output . prompt)
|
|
|
632 current nil 0 (cons nil nil))))
|
|
|
633 (setq comint-send-queue (cons interrupt (cons send comint-send-queue)))
|
|
|
634 (funcall comint-update-status 'interrupt)
|
|
|
635 (comint-interrupt-subjob))
|
|
|
636 (if (eq comint-send-queue comint-end-queue)
|
|
|
637 (setq comint-send-queue
|
|
|
638 (cons (car comint-send-queue)
|
|
|
639 (cons send comint-send-queue)))
|
|
|
640 (rplacd comint-send-queue (cons send (cdr comint-send-queue))))))
|
|
|
641
|
|
|
642 ;;;%Interface
|
|
|
643 (defun comint-setup-ipc (&optional force)
|
|
|
644 "Setup for IPC in the current buffer. If called interactively,
|
|
|
645 force comint-send-queue to be initialized."
|
|
|
646 (interactive "p")
|
|
|
647 (make-local-variable 'comint-send-newline)
|
|
|
648 (make-local-variable 'comint-always-scroll)
|
|
|
649 (make-local-variable 'comint-fix-error)
|
|
|
650 (make-local-variable 'comint-continue)
|
|
|
651 (make-local-variable 'comint-interrupt-regexp)
|
|
|
652 (make-local-variable 'comint-error-regexp)
|
|
|
653 (make-local-variable 'comint-output-filter)
|
|
|
654 (make-local-variable 'comint-interrupt-start)
|
|
|
655 (make-local-variable 'comint-handler)
|
|
|
656 (make-local-variable 'comint-update-status)
|
|
|
657 (make-local-variable 'comint-prompt-status)
|
|
|
658 (make-local-variable 'comint-send-queue)
|
|
|
659 (make-local-variable 'comint-end-queue)
|
|
|
660 (make-local-variable 'comint-queue-emptied)
|
|
|
661 (make-local-variable 'comint-output)
|
|
|
662 (make-local-variable 'comint-errorp)
|
|
|
663 (make-local-variable 'comint-status)
|
|
|
664 (make-local-variable 'comint-aborting)
|
|
|
665 (if (or force (not comint-send-queue))
|
|
|
666 (setq comint-send-queue
|
|
|
667 (list (list nil nil nil 'run "Top Level"
|
|
|
668 nil t nil 0 (cons nil nil)))
|
|
|
669 comint-end-queue comint-send-queue))
|
|
|
670 (let ((process (get-buffer-process (current-buffer))))
|
|
|
671 (set-process-filter process 'comint-process-filter)
|
|
|
672 (set-process-sentinel process 'comint-process-sentinel))
|
|
|
673 (setq mode-line-process 'comint-status))
|
|
|
674
|
|
|
675 ;;;%%Input
|
|
|
676 (defun comint-send (process string
|
|
|
677 &optional
|
|
|
678 no-insert
|
|
|
679 wait
|
|
|
680 status
|
|
|
681 message
|
|
|
682 handler
|
|
|
683 after)
|
|
|
684 "Do a send to PROCESS of STRING. Optionally specify NO-INSERT,
|
|
|
685 WAIT, STATUS, MESSAGE, HANDLER and AFTER. Without optional arguments,
|
|
|
686 this is just like process-send-string. If STRING is not a string,
|
|
|
687 then it is assumed to be an elisp function and will be called when
|
|
|
688 encountered in the send queue. The send will be the next one if WAIT,
|
|
|
689 after the last send if AFTER, otherwise it will be put at the end of
|
|
|
690 the queue. If WAIT is non-NIL or on the first send to a busy inferior,
|
|
|
691 the inferior will be interrupted if possible, see comint-interrupt for
|
|
|
692 more information. Once the send is sent, the process status will be
|
|
|
693 STATUS or 'run. Output of the send will be inserted into the process
|
|
|
694 buffer unless NO-INSERT. This function returns a list of \(result .
|
|
|
695 prompt). If WAIT is a string, output will be inserted until one
|
|
|
696 matches the string as a regexp. If WAIT is T, then PROMPT will have
|
|
|
697 the prompt when finished and RESULT will have the output. If PROMPT
|
|
|
698 is a list, then there was an error. If WAIT is not T, then the list
|
|
|
699 returned will change when the send has been sent and is finished. If
|
|
|
700 HANDLER is nil it will be set to comint-handler. If it is T, errors
|
|
|
701 will be ignored. When a send is finished, it calls handler with
|
|
|
702 \(error-p WAIT MESSAGE output prompt) which decides what to do with
|
|
|
703 the output.
|
|
|
704
|
|
|
705 VARIABLES:
|
|
|
706
|
|
|
707 comint-always-scroll will cause all process output to be visible.
|
|
|
708
|
|
|
709 comint-fix-error is the string used to fix errors.
|
|
|
710
|
|
|
711 comint-continue is the string used to continue after an interrupt.
|
|
|
712
|
|
|
713 comint-interrupt-regexp is the default regexp to use in finding the
|
|
|
714 start of the interrupt text.
|
|
|
715
|
|
|
716 comint-error-regexp will set comint-errorp if found in the process output.
|
|
|
717
|
|
|
718 FUNCTIONS: Each of the functions in these variables is called with
|
|
|
719 the buffer set to the appropriate process buffer and
|
|
|
720 comint-original-buffer bound to the buffer current when the process
|
|
|
721 filter was called.
|
|
|
722
|
|
|
723 comint-update-status is a function \(status) that is called each time
|
|
|
724 the process status changes.
|
|
|
725
|
|
|
726 comint-prompt-status is called with the old prompt and the last line.
|
|
|
727 It should return 'error if the last line is an error, T if it is a
|
|
|
728 prompt and nil otherwise. It should also update the process status by
|
|
|
729 funcalling comint-update-status.
|
|
|
730
|
|
|
731 comint-output-filter is a function \(output) for sends with NO-INSERT.
|
|
|
732 It should return the output string.
|
|
|
733
|
|
|
734 comint-interrupt-start is a function \(output) that returns the start
|
|
|
735 of the interrupt text in output using comint-interrupt-regexp to find it."
|
|
|
736 (save-excursion
|
|
|
737 (set-buffer (process-buffer process))
|
|
|
738 (let* ((inhibit-quit t)
|
|
|
739 (send (list string
|
|
|
740 no-insert
|
|
|
741 wait
|
|
|
742 (or status 'run)
|
|
|
743 message
|
|
|
744 (if (eq handler t) nil (or handler comint-handler))
|
|
|
745 ;; running, old-prompt, line
|
|
|
746 nil nil 0
|
|
|
747 ;; (output . prompt)
|
|
|
748 (cons nil nil)))
|
|
|
749 (pointer (comint-send-results send))
|
|
|
750 (top-level (eq comint-send-queue comint-end-queue))
|
|
|
751 (end (car comint-end-queue))
|
|
|
752 (current (car comint-send-queue))
|
|
|
753 (prompt (cdr (comint-send-results current)))
|
|
|
754 (ok nil))
|
|
|
755 (setq comint-aborting nil)
|
|
|
756 (if (and top-level (or (stringp wait) prompt))
|
|
|
757 (progn
|
|
|
758 (setq comint-send-queue (cons send comint-send-queue))
|
|
|
759 (comint-dispatch-send process))
|
|
|
760 (if (or (and wait (not after) (not prompt)) top-level)
|
|
|
761 (comint-interrupt process send)
|
|
|
762 (let ((looking t)
|
|
|
763 (next comint-send-queue))
|
|
|
764 (if after
|
|
|
765 (while (and looking next)
|
|
|
766 (if (eq (car next) comint-last-send)
|
|
|
767 (progn
|
|
|
768 (rplacd next (cons send (cdr next)))
|
|
|
769 (setq looking nil)))
|
|
|
770 (setq next (cdr next))))
|
|
|
771 (if looking
|
|
|
772 (progn
|
|
|
773 (rplaca comint-end-queue send)
|
|
|
774 (setq comint-end-queue
|
|
|
775 (rplacd comint-end-queue (cons end nil))))))))
|
|
|
776 (setq comint-last-send send)
|
|
|
777 (unwind-protect
|
|
|
778 (let ((inhibit-quit nil))
|
|
|
779 (if (eq wait t)
|
|
|
780 (while (not (cdr pointer))
|
|
|
781 (accept-process-output)
|
|
|
782 (sit-for 0)))
|
|
|
783 (setq ok pointer))
|
|
|
784 (if (not ok)
|
|
|
785 (if (eq send (car comint-send-queue))
|
|
|
786 (let ((interrupt
|
|
|
787 ;; string no-insert wait status message handler
|
|
|
788 (list nil t nil 'interrupt "Interrupt" nil
|
|
|
789 ;; running old-prompt line (output . prompt)
|
|
|
790 send (car (cdr (comint-send-variables send)))
|
|
|
791 nil (cons nil nil))))
|
|
|
792 (setq comint-send-queue
|
|
|
793 (cons interrupt (cdr comint-send-queue)))
|
|
|
794 (comint-interrupt-subjob))
|
|
|
795 (setq comint-send-queue (delq send comint-send-queue))))))))
|
|
|
796
|
|
|
797 ;;;
|
|
|
798 (defun comint-send-code (process code)
|
|
|
799 "Execute after the previous send in PROCESS queue CODE. You do not
|
|
|
800 want to execute synchronous sends in the code or it will lock up. "
|
|
|
801 (comint-send process code nil nil nil nil nil t))
|
|
|
802
|
|
|
803 ;;;
|
|
|
804 (defun comint-default-send (process string)
|
|
|
805 "Send to PROCESS top-level, STRING."
|
|
|
806 (save-excursion
|
|
|
807 (set-buffer (process-buffer process))
|
|
|
808 (let* ((top (car comint-end-queue))
|
|
|
809 (old (car top)))
|
|
|
810 (rplaca (cdr (cdr (cdr (cdr (car comint-end-queue))))) string)
|
|
|
811 (if (eq comint-send-queue comint-end-queue)
|
|
|
812 (progn (funcall comint-update-status 'run)
|
|
|
813 (rplaca (comint-send-variables (car comint-send-queue)) t)
|
|
|
814 (rplacd (comint-send-results (car comint-send-queue)) nil)
|
|
|
815 (comint-sender process string))
|
|
|
816 (rplaca top
|
|
|
817 (if old
|
|
|
818 (concat old (if comint-send-newline "\n") string)
|
|
|
819 string))))))
|
|
|
820
|
|
|
821 ;;;
|
|
|
822 (defun comint-sync (process start start-regexp end end-regexp)
|
|
|
823 "Synchronize with PROCESS output stream. START will be sent with
|
|
|
824 each prompt received until START-REGEXP shows up in the stream. Then
|
|
|
825 END will be sent and all output will be discarded until END-REGEXP
|
|
|
826 shows up in the output stream."
|
|
|
827 (comint-send
|
|
|
828 process
|
|
|
829 start
|
|
|
830 nil start-regexp 'sync "Start sync"
|
|
|
831 (function (lambda (error-p wait message output prompt)
|
|
|
832 (if (not (string-match wait output))
|
|
|
833 (comint-sender
|
|
|
834 (get-buffer-process (current-buffer))
|
|
|
835 (car (car comint-send-queue))))
|
|
|
836 nil)))
|
|
|
837 (comint-send
|
|
|
838 process
|
|
|
839 end
|
|
|
840 t end-regexp 'sync "End sync"
|
|
|
841 (function (lambda (&rest args) nil))))
|
|
|
842
|
|
|
843 ;;;
|
|
|
844 (defun comint-abort-sends (&optional process)
|
|
|
845 "Abort all of the pending sends for optional PROCESS and show their
|
|
|
846 messages in *Aborted Commands*."
|
|
|
847 (interactive)
|
|
|
848 (save-excursion
|
|
|
849 (setq process (or process (get-buffer-process (current-buffer))))
|
|
|
850 (set-buffer (process-buffer process))
|
|
|
851 (setq comint-aborting t)
|
|
|
852 (if (not (eq comint-send-queue comint-end-queue))
|
|
|
853 (let* ((inhibit-quit t)
|
|
|
854 (send (car comint-send-queue))
|
|
|
855 (vars (comint-send-variables send))
|
|
|
856 (pointer comint-send-queue)
|
|
|
857 (new nil)
|
|
|
858 (interrupt (and (car vars)
|
|
|
859 (not (cdr (comint-send-results send))))))
|
|
|
860 (if interrupt
|
|
|
861 (progn ;Sent, but no prompt
|
|
|
862 (if (consp (car vars))
|
|
|
863 (progn (setq new (list send))
|
|
|
864 (rplaca (cdr (cdr (cdr (cdr (cdr send)))))
|
|
|
865 (function (lambda (&rest args) t))))
|
|
|
866 (setq new
|
|
|
867 (list
|
|
|
868 (list nil t nil 'interrupt "Interrupt"
|
|
|
869 (function (lambda (&rest args) t))
|
|
|
870 send (car (cdr (comint-send-variables send)))
|
|
|
871 nil (cons nil nil))))
|
|
|
872 (comint-interrupt-subjob)))) ;Already interrupting
|
|
|
873 (save-excursion
|
|
|
874 (set-buffer (get-buffer-create "*Aborted Commands*"))
|
|
|
875 (delete-region (point-min) (point-max)))
|
|
|
876 (while (not (eq pointer comint-end-queue))
|
|
|
877 (let ((send (car pointer)))
|
|
|
878 (if (car (cdr (cdr (cdr (cdr send))))) ;Message
|
|
|
879 (save-excursion
|
|
|
880 (set-buffer "*Aborted Commands*")
|
|
|
881 (insert (comint-send-description send))
|
|
|
882 (insert "\n\n")))
|
|
|
883 (if (and comint-fix-error
|
|
|
884 (stringp (car (comint-send-variables send))))
|
|
|
885 ;; Interrupted
|
|
|
886 (setq new (cons
|
|
|
887 (list comint-fix-error t nil 'fix
|
|
|
888 "Fixing error" nil
|
|
|
889 nil nil 0 (cons nil nil))
|
|
|
890 new)))
|
|
|
891 (setq pointer (cdr pointer))))
|
|
|
892 (bury-buffer "*Aborted Commands*")
|
|
|
893 (rplaca (car comint-end-queue) nil)
|
|
|
894 (setq comint-send-queue
|
|
|
895 (reverse (cons (car comint-end-queue) new))
|
|
|
896 comint-end-queue
|
|
|
897 (let ((pointer comint-send-queue))
|
|
|
898 (while (cdr pointer)
|
|
|
899 (setq pointer (cdr pointer)))
|
|
|
900 pointer))
|
|
|
901 (run-hooks 'comint-abort-hook)
|
|
|
902 (if (not interrupt) (comint-dispatch-send process))))))
|
|
|
903
|
|
|
904 ;;;
|
|
|
905 (defun comint-current-send (showp)
|
|
|
906 "Show the message of the current send in the minibuffer."
|
|
|
907 (interactive "P")
|
|
|
908 (if showp
|
|
|
909 (with-output-to-temp-buffer comint-output-buffer
|
|
|
910 (let ((send comint-send-queue))
|
|
|
911 (save-excursion
|
|
|
912 (set-buffer comint-output-buffer)
|
|
|
913 (insert "Pending commands:\n")
|
|
|
914 (while send
|
|
|
915 (let ((message (car (cdr (cdr (cdr (cdr (car send))))))))
|
|
|
916 (if message (insert (concat message "\n"))))
|
|
|
917 (setq send (cdr send)))))))
|
|
|
918 (message
|
|
|
919 (concat "Command: "
|
|
|
920 (or (comint-send-description (car comint-send-queue))
|
|
|
921 "Unknown"))))
|
|
|
922
|
|
|
923
|
|
|
924 ;;;
|
|
|
925 (defun comint-display-output (text &optional buffer)
|
|
|
926 "Put TEXT in optional BUFFER and show it in a small temporary window."
|
|
|
927 (setq buffer (or buffer comint-output-buffer))
|
|
|
928 (with-output-to-temp-buffer buffer
|
|
|
929 (save-excursion
|
|
|
930 (set-buffer buffer)
|
|
|
931 (insert text)
|
|
|
932 (set-buffer-modified-p nil)))
|
|
|
933 text)
|
|
|
934 ;; Perhaps this should use ilisp-display-output.
|
|
|
935
|
|
|
936 ;;;
|
|
|
937 (defun comint-display-error (text)
|
|
|
938 "Put TEXT in the comint-error-buffer and display it."
|
|
|
939 (comint-display-output text comint-error-buffer))
|
|
|
940
|
|
|
941 (provide 'comint-ipc)
|
