#| -*-Scheme-*-

$Id: process.scm,v 1.65 2003/02/14 18:28:13 cph Exp $

Copyright 1991,1992,1993,1996,1997,1999 Massachusetts Institute of Technology
Copyright 2000,2001,2002,2003 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.

|#

;;;; Subprocess Support
;; package: (edwin process)

(declare (usual-integrations))

(define subprocesses-available? #t)

(add-event-receiver! editor-initializations
  (lambda ()
    (set! edwin-processes '())
    (set! process-input-queue (cons '() '()))
    (set-variable! exec-path (os/exec-path))
    (set-variable! shell-file-name (os/shell-file-name))))

(define edwin-processes)

(define-variable exec-path
  "List of directories to search programs to run in subprocesses.
Each element is a string (directory name) or #F (try default directory)."
  '()
  (lambda (exec-path)
    (and (list? exec-path)
	 (for-all? exec-path
	   (lambda (element)
	     (or (not element)
		 (pathname? element)))))))

(define-variable process-connection-type
  "Control type of device used to communicate with subprocesses.
Values are #f to use a pipe, #t for a pty (or pipe if ptys not supported).
Value takes effect when `start-process' is called."
  #t
  boolean?)

(define-variable delete-exited-processes
  "True means delete processes immediately when they exit.
False means don't delete them until \\[list-processes] is run."
  #t
  boolean?)

(define-variable shell-file-name
  "File name to load inferior shells from.
Initialized from the SHELL environment variable."
  ""
  string?)

(define-structure (process
		   (constructor %make-process (subprocess name %buffer)))
  (subprocess #f read-only #t)
  (name #f read-only #t)
  %buffer
  (mark #f)
  (filter #f)
  (sentinel #f)
  (kill-without-query #f)
  (notification-tick (cons #f #f))
  (input-registration #f))

(define-integrable (process-arguments process)
  (subprocess-arguments (process-subprocess process)))

(define-integrable (process-output-port process)
  (subprocess-output-port (process-subprocess process)))

(define-integrable (process-status-tick process)
  (subprocess-status-tick (process-subprocess process)))

(define-integrable (process-exit-reason process)
  (subprocess-exit-reason (process-subprocess process)))

(define (process-status process)
  (status->emacs-status (subprocess-status (process-subprocess process))))

(define (status->emacs-status status)
  (case status
    ((RUNNING) 'RUN)
    ((STOPPED) 'STOP)
    ((EXITED) 'EXIT)
    ((SIGNALLED) 'SIGNAL)
    (else status)))

(define (process-runnable? process)
  (let ((status (subprocess-status (process-subprocess process))))
    (or (eq? 'RUNNING status)
	(eq? 'STOPPED status))))

(define-integrable (process-buffer process)
  (process-%buffer process))

(define (set-process-buffer! process buffer)
  (without-interrupts
   (lambda ()
     (if (not (eq? buffer (process-buffer process)))
	 (begin
	   (set-process-%buffer! process buffer)
	   (update-process-mark! process))))))

(define (update-process-mark! process)
  (set-process-mark!
   process
   (let ((buffer (process-buffer process)))
     (and buffer
	  (mark-right-inserting-copy (buffer-end buffer))))))

(define (deregister-process-input process)
  (let ((registration (process-input-registration process)))
    (if registration
	(begin
	  (set-process-input-registration! process #f)
	  (deregister-io-thread-event registration)))))

(define (start-process name buffer environment program . arguments)
  (let ((make-subprocess
	 (let ((directory (buffer-default-directory buffer)))
	   (let ((filename
		  (os/find-program program directory (ref-variable exec-path)))
		 (arguments (list->vector (cons program arguments)))
		 (pty? (ref-variable process-connection-type buffer)))
	     (lambda ()
	       (start-subprocess filename
				 arguments
				 (cons environment (->namestring directory))
				 pty?))))))
    (without-interrupts
     (lambda ()
       (let ((subprocess (make-subprocess)))
	 (let ((process
		(%make-process
		 subprocess
		 (do ((n 2 (+ n 1))
		      (name* name
			     (string-append name
					    "<" (number->string n) ">")))
		     ((not (get-process-by-name name*)) name*))
		 buffer)))
	   (let ((channel (subprocess-input-channel subprocess)))
	     (if channel
		 (begin
		   (channel-nonblocking channel)
		   (register-process-input process channel))))
	   (update-process-mark! process)
	   (subprocess-put! subprocess 'EDWIN-PROCESS process)
	   (set! edwin-processes (cons process edwin-processes))
	   (buffer-modeline-event! buffer 'PROCESS-STATUS)
	   process))))))

(define (start-subprocess filename arguments environment pty?)
  (if (and pty? ((ucode-primitive have-ptys? 0)))
      (start-pty-subprocess filename arguments environment)
      (start-pipe-subprocess filename arguments environment)))

(define (delete-process process)
  (let ((subprocess (process-subprocess process)))
    (without-interrupts
     (lambda ()
       (set! edwin-processes (delq! process edwin-processes))
       (subprocess-remove! subprocess 'EDWIN-PROCESS)
       (if (process-runnable? process)
	   (begin
	     (subprocess-kill subprocess)
	     (%perform-status-notification process 'SIGNALLED #f)))
       (deregister-process-input process)
       (let ((buffer (process-buffer process)))
	 (if (buffer-alive? buffer)
	     (buffer-modeline-event! buffer 'PROCESS-STATUS)))
       (subprocess-delete subprocess)))))

(define (get-process-by-name name)
  (let loop ((processes edwin-processes))
    (cond ((null? processes) #f)
	  ((string=? name (process-name (car processes))) (car processes))
	  (else (loop (cdr processes))))))

(define (get-buffer-process buffer)
  (let loop ((processes edwin-processes))
    (cond ((null? processes) #f)
	  ((eq? buffer (process-buffer (car processes))) (car processes))
	  (else (loop (cdr processes))))))

(define (buffer-processes buffer)
  (let loop ((processes edwin-processes))
    (cond ((null? processes)
	   '())
	  ((eq? buffer (process-buffer (car processes)))
	   (cons (car processes) (loop (cdr processes))))
	  (else
	   (loop (cdr processes))))))

;;;; Input and Output

(define process-input-queue)

(define (register-process-input process channel)
  (set-process-input-registration!
   process
   (permanently-register-io-thread-event
    (channel-descriptor-for-select channel)
    'READ
    (current-thread)
    (lambda (mode)
      mode
      (let ((queue process-input-queue))
	(if (not (memq process (car queue)))
	    (let ((tail (list process)))
	      (if (null? (cdr queue))
		  (set-car! queue tail)
		  (set-cdr! (cdr queue) tail))
	      (set-cdr! queue tail))))))))

(define (process-output-available?)
  (not (null? (car process-input-queue))))

(define (accept-process-output)
  (let ((queue process-input-queue))
    (let loop ((output? #f))
      (if (null? (car queue))
	  output?
	  (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
	    (let ((process (caar queue)))
	      (set-car! queue (cdar queue))
	      (if (null? (car queue))
		  (set-cdr! queue '()))
	      (let ((output?
		     (if (poll-process-for-output process #t) #t output?)))
		(set-interrupt-enables! interrupt-mask)
		(loop output?))))))))

(define (poll-process-for-output process do-status?)
  (and (let ((channel (subprocess-input-channel (process-subprocess process))))
	 (and channel
	      (channel-open? channel)))
       (let ((port (subprocess-input-port (process-subprocess process)))
	     (buffer (make-string 512))
	     (output? #f))
	 (let ((close-input
		(lambda ()
		  (deregister-process-input process)
		  (close-port port)
		  (if do-status?
		      (begin
			(%update-global-notification-tick)
			(if (poll-process-for-status-change process)
			    (set! output? #t)))))))
	   (let loop ()
	     (let ((n
		    (call-with-current-continuation
		     (lambda (k)
		       (bind-condition-handler (list condition-type:port-error)
			   (lambda (condition) condition (k 0))
			 (lambda ()
			   (input-port/read-string! port buffer)))))))
	       (if n
		   (if (fix:= n 0)
		       (close-input)
		       (begin
			 (if (output-substring process buffer n)
			     (set! output? #t))
			 (loop)))))))
	 output?)))

(define (process-send-eof process)
  (process-send-char process #\EOT))

(define (process-send-substring process string start end)
  (let ((port (process-output-port process)))
    (output-port/write-substring port string start end)
    (output-port/flush-output port)))

(define (process-send-string process string)
  (let ((port (process-output-port process)))
    (output-port/write-string port string)
    (output-port/flush-output port)))

(define (process-send-char process char)
  (let ((port (process-output-port process)))
    (output-port/write-char port char)
    (output-port/flush-output port)))

(define (process-status-changes?)
  (without-interrupts
   (lambda ()
     (not (eq? (subprocess-global-status-tick) global-notification-tick)))))

(define (handle-process-status-changes)
  (without-interrupts
   (lambda ()
     (and (%update-global-notification-tick)
	  (let loop ((processes edwin-processes) (output? #f))
	    (if (null? processes)
		output?
		(loop (cdr processes)
		      (if (poll-process-for-status-change (car processes))
			  #t
			  output?))))))))

(define (%update-global-notification-tick)
  (let ((tick (subprocess-global-status-tick)))
    (and (not (eq? tick global-notification-tick))
	 (begin
	   (set! global-notification-tick tick)
	   #t))))

(define global-notification-tick
  (cons #f #f))

(define (poll-process-for-status-change process)
  (let ((status (subprocess-status (process-subprocess process))))
    (and (not (eq? (process-notification-tick process)
		   (process-status-tick process)))
	 (perform-status-notification process
				      status
				      (process-exit-reason process)))))

(define (perform-status-notification process status reason)
  (poll-process-for-output process #f)
  (let ((value (%perform-status-notification process status reason)))
    (if (and (or (eq? 'EXITED status)
		 (eq? 'SIGNALLED status))
	     (ref-variable delete-exited-processes))
	(delete-process process))
    value))

(define (%perform-status-notification process status reason)
  (set-process-notification-tick! process (process-status-tick process))
  (cond ((process-sentinel process)
	 =>
	 (lambda (sentinel)
	   (sentinel process (status->emacs-status status) reason)
	   #t))
	((eq? status 'RUNNING)
	 #f)
	(else
	 (let ((message
		(string-append "\nProcess "
			       (process-name process)
			       " "
			       (process-status-message
				(status->emacs-status status)
				reason)
			       "\n")))
	   (output-substring process
			     message
			     (string-length message))))))

(define (process-status-message status reason)
  (let ((message-with-reason
	 (lambda (prefix connective)
	   (if reason
	       (string-append prefix
			      (if connective (string-append " " connective) "")
			      " "
			      (number->string reason))
	       prefix))))
    (case status
      ((RUN) "running")
      ((STOP) (message-with-reason "stopped by signal" #f))
      ((EXIT)
       (if (zero? reason)
	   "finished"
	   (message-with-reason "exited abnormally" "with code")))
      ((SIGNAL) (message-with-reason "terminated by signal" #f))
      (else (error "illegal process status" status)))))

(define (output-substring process string length)
  (cond ((process-filter process)
	 =>
	 (lambda (filter)
	   (filter process string 0 length)))
	((process-mark process)
	 =>
	 (lambda (mark)
	   (let ((index (mark-index mark)))
	     (group-insert-substring! (mark-group mark) index string 0 length)
	     (set-mark-index! mark (+ index length)))
	   #t))
	(else #f)))

(define (add-process-filter process filter)
  (let ((filter* (process-filter process)))
    (if (filter-dispatcher? filter*)
	(add-filter-to-dispatcher filter* filter)
	(set-process-filter! process
			     (make-filter-dispatcher (if filter*
							 (list filter* filter)
							 (list filter)))))))

(define (remove-process-filter process filter)
  (set-process-filter!
   process
   (let ((filter* (process-filter process)))
     (cond ((eq? filter filter*) #f)
	   ((filter-dispatcher? filter*)
	    (remove-filter-from-dispatcher filter* filter))
	   (else filter*)))))

(define (make-filter-dispatcher filters)
  (make-entity filter-dispatcher-procedure filters))

(define (filter-dispatcher? object)
  (and (entity? object)
       (eq? filter-dispatcher-procedure (entity-procedure object))))

(define (filter-dispatcher-procedure dispatcher process string start end)
  (let loop ((filters (entity-extra dispatcher)))
    (and (not (null? filters))
	 (or ((car filters) process string start end)
	     (loop (cdr filters))))))

(define (add-filter-to-dispatcher dispatcher filter)
  (let ((filters (entity-extra dispatcher)))
    (if (pair? filters)
	(set-cdr! (last-pair filters) (list filter))
	(set-entity-extra! dispatcher (list filter)))))

(define (remove-filter-from-dispatcher dispatcher filter)
  (let ((filters (delq! filter (entity-extra dispatcher))))
    (set-entity-extra! dispatcher filters)
    (and (not (null? filters))
	 dispatcher)))

(define (standard-process-filter filter)
  (lambda (process string start end)
    (let ((mark (process-mark process)))
      (and mark
	   (begin
	     (filter mark string start end)
	     #t)))))

;;;; Signals

(define (signal-process process signal group?)
  (let ((process (process-subprocess process)))
    (let ((pty-master (and group? (subprocess-pty-master process))))
      (if pty-master
	  (pty-master-send-signal pty-master signal)
	  (subprocess-signal process signal)))))

(define (interrupt-process process group?)
  (let ((process (process-subprocess process)))
    (let ((pty-master (and group? (subprocess-pty-master process))))
      (if pty-master
	  (pty-master-interrupt pty-master)
	  (subprocess-interrupt process)))))

(define (quit-process process group?)
  (let ((process (process-subprocess process)))
    (let ((pty-master (and group? (subprocess-pty-master process))))
      (if pty-master
	  (pty-master-quit pty-master)
	  (subprocess-quit process)))))

(define (hangup-process process group?)
  (let ((process (process-subprocess process)))
    (let ((pty-master (and group? (subprocess-pty-master process))))
      (if pty-master
	  (pty-master-hangup pty-master)
	  (subprocess-hangup process)))))

(define (stop-process process group?)
  (let ((process (process-subprocess process)))
    (let ((pty-master (and group? (subprocess-pty-master process))))
      (if pty-master
	  (pty-master-stop pty-master)
	  (subprocess-stop process)))))

(define (continue-process process group?)
  (let ((process (process-subprocess process)))
    (let ((pty-master (and group? (subprocess-pty-master process))))
      (if pty-master
	  (pty-master-continue pty-master)
	  (subprocess-continue-background process)))))

(define (kill-process process group?)
  (let ((process (process-subprocess process)))
    (let ((pty-master (and group? (subprocess-pty-master process))))
      (if pty-master
	  (pty-master-kill pty-master)
	  (subprocess-kill process)))))

;;;; LIST-PROCESSES

(define-command list-processes
  "Display a list of all processes.
\(Any processes listed as exited or signalled are actually eliminated
after the listing is made.)"
  ()
  (lambda ()
    (let ((buffer (temporary-buffer "*Process List*")))
      (let ((point (buffer-point buffer)))
	(let ((write-line
	       (lambda (process status buffer command)
		 (insert-string process point)
		 (insert-horizontal-space 13 point)
		 (insert-string status point)
		 (insert-horizontal-space 24 point)
		 (insert-string buffer point)
		 (insert-horizontal-space 40 point)
		 (insert-string command point)
		 (insert-newline point))))
	  (write-line "Process" "Status" "Buffer" "Command")
	  (write-line "-------" "------" "------" "-------")
	  (do ((processes edwin-processes (cdr processes)))
	      ((null? processes))
	    (let ((process (car processes)))
	      (write-line (or (process-name process) "")
			  (let ((status (process-status process)))
			    (let ((name (symbol-name status)))
			      (if (or (eq? 'EXIT status)
				      (eq? 'SIGNAL status))
				  (let ((reason (process-exit-reason process)))
				    (delete-process process)
				    (if (and (eq? 'EXIT status)
					     (zero? reason))
					name
					(string-append
					 name
					 " "
					 (number->string reason))))
				  name)))
			  (let ((buffer (process-buffer process)))
			    (cond ((not buffer) "(none)")
				  ((buffer-alive? buffer) (buffer-name buffer))
				  (else "(killed)")))
			  (process-arguments->string
			   (process-arguments process)))))))
      (set-buffer-point! buffer (buffer-start buffer))
      (buffer-not-modified! buffer)
      (pop-up-buffer buffer #f))))

(define (process-arguments->string arguments)
  (if (zero? (vector-length arguments))
      ""
      (apply string-append
	     (let loop ((arguments (vector->list arguments)))
	       (cons (car arguments)
		     (if (null? (cdr arguments))
			 '()
			 (cons " " (loop (cdr arguments)))))))))

(define (process-list)
  (list-copy edwin-processes))

;;;; Synchronous Subprocesses

(define (run-synchronous-process input-region output-mark directory pty?
				 program . arguments)
  (let ((input-port
	 (and input-region
	      (make-buffer-input-port (region-start input-region)
				      (region-end input-region))))
	(output-port
	 (and output-mark
	      (mark->output-port
	       (if (pair? output-mark) (car output-mark) output-mark))))
	(mark-translation
	 (lambda (mark)
	   (let ((pathname
		  (let ((buffer (mark-buffer mark)))
		    (and buffer
			 (buffer-pathname buffer)))))
	     (if pathname
		 (pathname-newline-translation pathname)
		 'DEFAULT)))))
    (let ((result
	   (run-synchronous-process-1 output-port
	     (lambda ()
	       (run-synchronous-subprocess
		program arguments
		'INPUT input-port
		'INPUT-LINE-TRANSLATION
		(if input-region
		    (let ((mark (region-start input-region)))
		      (and (ref-variable translate-file-data-on-output mark)
			   (mark-translation mark)))
		    'DEFAULT)
		'OUTPUT output-port
		'OUTPUT-LINE-TRANSLATION
		(if output-port
		    (let ((mark (output-port->mark output-port)))
		      (and (ref-variable translate-file-data-on-input mark)
			   (mark-translation mark)))
		    'DEFAULT)
		'REDISPLAY-HOOK
		(and (if (pair? output-mark) (cdr output-mark) #f)
		     (lambda () (update-screens! '(IGNORE-INPUT))))
		'WORKING-DIRECTORY directory
		'USE-PTY? pty?)))))
      (if input-port (close-port input-port))
      (if output-port (close-port output-port))
      result)))

(define (run-synchronous-process-1 port thunk)
  (call-with-current-continuation
   (lambda (k)
     (bind-condition-handler
	 (list condition-type:subprocess-abnormal-termination)
	 (lambda (condition)
	   (if port
	       (begin
		 (fresh-line port)
		 (newline port)
		 (write-condition-report condition port)
		 (newline port)))
	   (k
	    (cons (if (eq? condition-type:subprocess-stopped
			   (condition/type condition))
		      'STOPPED
		      'SIGNALLED)
		  (access-condition condition 'REASON))))
       (lambda ()
	 (let ((code (thunk)))
	   (if (and port (not (= 0 code)))
	       (begin
		 (fresh-line port)
		 (newline port)
		 (write-string "Subprocess exited abnormally with code " port)
		 (write code port)
		 (write-string "." port)
		 (newline port)))
	   (cons 'EXITED code)))))))

;;;; Shell Commands

(define-command shell-command
  "Execute string COMMAND in inferior shell; display output, if any.
Optional second arg true (prefix arg, if interactive) means
insert output in current buffer after point (leave mark after it)."
  (lambda ()
    (list (shell-command-prompt "Shell command")
	  (command-argument)))
  (lambda (command insert-at-point?)
    (let ((directory (buffer-default-directory (current-buffer))))
      (if insert-at-point?
	  (begin
	    (if (buffer-read-only? (current-buffer))
		(barf-if-read-only))
	    (let ((point (current-point)))
	      (push-current-mark! point)
	      (shell-command #f point directory #f command))
	    ((ref-command exchange-point-and-mark)))
	  (shell-command-pop-up-output
	   (lambda (output-mark)
	      (shell-command #f output-mark directory #f command)))))))

(define-command shell-command-on-region
  "Execute string COMMAND in inferior shell with region as input.
Normally display output (if any) in temp buffer;
Prefix arg means replace the region with it."
  (lambda ()
    (list (current-region)
	  (shell-command-prompt "Shell command on region")
	  (command-argument)))
  (lambda (region command replace-region?)
    (let ((directory (buffer-default-directory (current-buffer))))
      (if replace-region?
	  (let ((point (current-point))
		(mark (current-mark)))
	    (let ((swap? (mark< point mark))
		  (temp))
	      (dynamic-wind
	       (lambda ()
		 (set! temp (temporary-buffer " *shell-output*"))
		 unspecific)
	       (lambda ()
		 (shell-command (make-region point mark)
				(buffer-start temp)
				directory
				#f
				command)
		 (without-interrupts
		  (lambda ()
		    (delete-string point mark)
		    (insert-region (buffer-start temp)
				   (buffer-end temp)
				   (current-point)))))
	       (lambda ()
		 (kill-buffer temp)
		 (set! temp)
		 unspecific))
	      (if swap? ((ref-command exchange-point-and-mark)))))
	  (shell-command-pop-up-output
	   (lambda (output-mark)
	     (shell-command region output-mark directory #f command)))))))

(define (shell-command-prompt prompt)
  (prompt-for-string prompt #f
		     'DEFAULT-TYPE 'INSERTED-DEFAULT
		     'HISTORY 'SHELL-COMMAND))

(define (shell-command-pop-up-output generate-output)
  (let ((buffer (temporary-buffer "*Shell Command Output*")))
    (let ((start (buffer-start buffer)))
      (generate-output start)
      (set-buffer-point! buffer start)
      (if (mark< start (buffer-end buffer))
	  (pop-up-buffer buffer #f)
	  (message "(Shell command completed with no output)")))))

(define (shell-command input-region output-mark directory pty? command)
  (apply run-synchronous-process
	 input-region output-mark directory pty?
	 (ref-variable shell-file-name)
	 (os/form-shell-command command)))