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