cgit.sxemacs.org Git - packages/blob - xemacs-packages/ilisp/comint-ipc.el

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