Mercurial > hg > xemacs-beta

comparison lisp/ilisp/comint-ipc.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children b82b59fe008d
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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)