1#| -*-Scheme-*-
2
3Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5    2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6    Institute of Technology
7
8This file is part of MIT/GNU Scheme.
9
10MIT/GNU Scheme is free software; you can redistribute it and/or modify
11it under the terms of the GNU General Public License as published by
12the Free Software Foundation; either version 2 of the License, or (at
13your option) any later version.
14
15MIT/GNU Scheme is distributed in the hope that it will be useful, but
16WITHOUT ANY WARRANTY; without even the implied warranty of
17MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
18General Public License for more details.
19
20You should have received a copy of the GNU General Public License
21along with MIT/GNU Scheme; if not, write to the Free Software
22Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23USA.
24
25|#
26
27;;;; Subprocess Support
28;; package: (edwin process)
29
30(declare (usual-integrations))
31
32(define subprocesses-available? #t)
33
34(add-event-receiver! editor-initializations
35  (lambda ()
36    (set! edwin-processes '())
37    (set! process-input-queue (cons '() '()))
38    (set-variable! exec-path (os/exec-path))
39    (set-variable! shell-file-name (os/shell-file-name))))
40
41(define edwin-processes)
42
43(define-variable exec-path
44  "List of directories to search programs to run in subprocesses.
45Each element is a string (directory name) or #F (try default directory)."
46  '()
47  (lambda (exec-path)
48    (and (list? exec-path)
49	 (for-all? exec-path
50	   (lambda (element)
51	     (or (not element)
52		 (pathname? element)))))))
53
54(define-variable process-connection-type
55  "Control type of device used to communicate with subprocesses.
56Values are #f to use a pipe, #t for a pty (or pipe if ptys not supported).
57Value takes effect when `start-process' is called."
58  #t
59  boolean?)
60
61(define-variable delete-exited-processes
62  "True means delete processes immediately when they exit.
63False means don't delete them until \\[list-processes] is run."
64  #t
65  boolean?)
66
67(define-variable shell-file-name
68  "File name to load inferior shells from.
69Initialized from the SHELL environment variable."
70  ""
71  string?)
72
73(define-structure (process
74		   (constructor %make-process (subprocess name %buffer)))
75  (subprocess #f read-only #t)
76  (name #f read-only #t)
77  %buffer
78  (mark #f)
79  (filter #f)
80  (sentinel #f)
81  (kill-without-query #f)
82  (notification-tick (cons #f #f))
83  (input-registration #f))
84
85(define-integrable (process-arguments process)
86  (subprocess-arguments (process-subprocess process)))
87
88(define-integrable (process-output-port process)
89  (subprocess-output-port (process-subprocess process)))
90
91(define-integrable (process-status-tick process)
92  (subprocess-status-tick (process-subprocess process)))
93
94(define-integrable (process-exit-reason process)
95  (subprocess-exit-reason (process-subprocess process)))
96
97(define (process-status process)
98  (status->emacs-status (subprocess-status (process-subprocess process))))
99
100(define (status->emacs-status status)
101  (case status
102    ((RUNNING) 'RUN)
103    ((STOPPED) 'STOP)
104    ((EXITED) 'EXIT)
105    ((SIGNALLED) 'SIGNAL)
106    (else status)))
107
108(define (process-runnable? process)
109  (let ((status (subprocess-status (process-subprocess process))))
110    (or (eq? 'RUNNING status)
111	(eq? 'STOPPED status))))
112
113(define-integrable (process-buffer process)
114  (process-%buffer process))
115
116(define (set-process-buffer! process buffer)
117  (without-interrupts
118   (lambda ()
119     (if (not (eq? buffer (process-buffer process)))
120	 (begin
121	   (set-process-%buffer! process buffer)
122	   (update-process-mark! process))))))
123
124(define (update-process-mark! process)
125  (set-process-mark!
126   process
127   (let ((buffer (process-buffer process)))
128     (and buffer
129	  (mark-right-inserting-copy (buffer-end buffer))))))
130
131(define (deregister-process-input process)
132  (let ((registration (process-input-registration process)))
133    (if registration
134	(begin
135	  (set-process-input-registration! process #f)
136	  (deregister-io-thread-event registration)))))
137
138(define (start-process name buffer environment program . arguments)
139  (let ((make-subprocess
140	 (let ((directory (buffer-default-directory buffer)))
141	   (let ((filename
142		  (os/find-program program directory (ref-variable exec-path)))
143		 (arguments (list->vector (cons program arguments)))
144		 (pty? (ref-variable process-connection-type buffer)))
145	     (lambda ()
146	       (start-subprocess filename
147				 arguments
148				 (cons environment (->namestring directory))
149				 pty?))))))
150    (without-interrupts
151     (lambda ()
152       (let ((subprocess (make-subprocess)))
153	 (let ((process
154		(%make-process
155		 subprocess
156		 (do ((n 2 (+ n 1))
157		      (name* name
158			     (string-append name
159					    "<" (number->string n) ">")))
160		     ((not (get-process-by-name name*)) name*))
161		 buffer)))
162	   (let ((channel (subprocess-input-channel subprocess)))
163	     (if channel
164		 (begin
165		   (channel-nonblocking channel)
166		   (register-process-input process channel))))
167	   (update-process-mark! process)
168	   (subprocess-put! subprocess 'EDWIN-PROCESS process)
169	   (set! edwin-processes (cons process edwin-processes))
170	   (buffer-modeline-event! buffer 'PROCESS-STATUS)
171	   process))))))
172
173(define (start-subprocess filename arguments environment pty?)
174  (if (and pty? ((ucode-primitive have-ptys? 0)))
175      (start-pty-subprocess filename arguments environment)
176      (start-pipe-subprocess filename arguments environment)))
177
178(define (delete-process process)
179  (let ((subprocess (process-subprocess process)))
180    (without-interrupts
181     (lambda ()
182       (set! edwin-processes (delq! process edwin-processes))
183       (subprocess-remove! subprocess 'EDWIN-PROCESS)
184       (if (process-runnable? process)
185	   (begin
186	     (subprocess-kill subprocess)
187	     (%perform-status-notification process 'SIGNALLED #f)))
188       (deregister-process-input process)
189       (let ((buffer (process-buffer process)))
190	 (if (buffer-alive? buffer)
191	     (buffer-modeline-event! buffer 'PROCESS-STATUS)))
192       (subprocess-delete subprocess)))))
193
194(define (get-process-by-name name)
195  (let loop ((processes edwin-processes))
196    (cond ((null? processes) #f)
197	  ((string=? name (process-name (car processes))) (car processes))
198	  (else (loop (cdr processes))))))
199
200(define (get-buffer-process buffer)
201  (let loop ((processes edwin-processes))
202    (cond ((null? processes) #f)
203	  ((eq? buffer (process-buffer (car processes))) (car processes))
204	  (else (loop (cdr processes))))))
205
206(define (buffer-processes buffer)
207  (let loop ((processes edwin-processes))
208    (cond ((null? processes)
209	   '())
210	  ((eq? buffer (process-buffer (car processes)))
211	   (cons (car processes) (loop (cdr processes))))
212	  (else
213	   (loop (cdr processes))))))
214
215;;;; Input and Output
216
217(define process-input-queue)
218
219(define (register-process-input process channel)
220  (set-process-input-registration!
221   process
222   (permanently-register-io-thread-event
223    (channel-descriptor-for-select channel)
224    'READ
225    (current-thread)
226    (lambda (mode)
227      mode
228      (let ((queue process-input-queue))
229	(if (not (memq process (car queue)))
230	    (let ((tail (list process)))
231	      (if (null? (cdr queue))
232		  (set-car! queue tail)
233		  (set-cdr! (cdr queue) tail))
234	      (set-cdr! queue tail))))))))
235
236(define (process-output-available?)
237  (not (null? (car process-input-queue))))
238
239(define (accept-process-output)
240  (let ((queue process-input-queue))
241    (let loop ((output? #f))
242      (if (null? (car queue))
243	  output?
244	  (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok)))
245	    (let ((process (caar queue)))
246	      (set-car! queue (cdar queue))
247	      (if (null? (car queue))
248		  (set-cdr! queue '()))
249	      (let ((output?
250		     (if (poll-process-for-output process #t) #t output?)))
251		(set-interrupt-enables! interrupt-mask)
252		(loop output?))))))))
253
254(define (poll-process-for-output process do-status?)
255  (and (let ((channel (subprocess-input-channel (process-subprocess process))))
256	 (and channel
257	      (channel-open? channel)))
258       (let ((port (subprocess-input-port (process-subprocess process)))
259	     (buffer (make-string 512))
260	     (output? #f))
261	 (let ((close-input
262		(lambda ()
263		  (deregister-process-input process)
264		  (close-port port)
265		  (if do-status?
266		      (begin
267			(%update-global-notification-tick)
268			(if (poll-process-for-status-change process)
269			    (set! output? #t)))))))
270	   (let loop ()
271	     (let ((n
272		    (call-with-current-continuation
273		     (lambda (k)
274		       (bind-condition-handler (list condition-type:port-error)
275			   (lambda (condition) condition (k 0))
276			 (lambda ()
277			   (input-port/read-string! port buffer)))))))
278	       (if n
279		   (if (fix:= n 0)
280		       (close-input)
281		       (begin
282			 (if (output-substring process buffer n)
283			     (set! output? #t))
284			 (loop)))))))
285	 output?)))
286
287(define (process-send-eof process)
288  (process-send-char process #\EOT))
289
290(define (process-send-substring process string start end)
291  (let ((port (process-output-port process)))
292    (output-port/write-substring port string start end)
293    (output-port/flush-output port)))
294
295(define (process-send-string process string)
296  (let ((port (process-output-port process)))
297    (output-port/write-string port string)
298    (output-port/flush-output port)))
299
300(define (process-send-char process char)
301  (let ((port (process-output-port process)))
302    (output-port/write-char port char)
303    (output-port/flush-output port)))
304
305(define (process-status-changes?)
306  (without-interrupts
307   (lambda ()
308     (not (eq? (subprocess-global-status-tick) global-notification-tick)))))
309
310(define (handle-process-status-changes)
311  (without-interrupts
312   (lambda ()
313     (and (%update-global-notification-tick)
314	  (let loop ((processes edwin-processes) (output? #f))
315	    (if (null? processes)
316		output?
317		(loop (cdr processes)
318		      (if (poll-process-for-status-change (car processes))
319			  #t
320			  output?))))))))
321
322(define (%update-global-notification-tick)
323  (let ((tick (subprocess-global-status-tick)))
324    (and (not (eq? tick global-notification-tick))
325	 (begin
326	   (set! global-notification-tick tick)
327	   #t))))
328
329(define global-notification-tick
330  (cons #f #f))
331
332(define (poll-process-for-status-change process)
333  (let ((status (subprocess-status (process-subprocess process))))
334    (and (not (eq? (process-notification-tick process)
335		   (process-status-tick process)))
336	 (perform-status-notification process
337				      status
338				      (process-exit-reason process)))))
339
340(define (perform-status-notification process status reason)
341  (poll-process-for-output process #f)
342  (let ((value (%perform-status-notification process status reason)))
343    (if (and (or (eq? 'EXITED status)
344		 (eq? 'SIGNALLED status))
345	     (ref-variable delete-exited-processes))
346	(delete-process process))
347    value))
348
349(define (%perform-status-notification process status reason)
350  (set-process-notification-tick! process (process-status-tick process))
351  (cond ((process-sentinel process)
352	 =>
353	 (lambda (sentinel)
354	   (sentinel process (status->emacs-status status) reason)
355	   #t))
356	((eq? status 'RUNNING)
357	 #f)
358	(else
359	 (let ((message
360		(string-append "\nProcess "
361			       (process-name process)
362			       " "
363			       (process-status-message
364				(status->emacs-status status)
365				reason)
366			       "\n")))
367	   (output-substring process
368			     message
369			     (string-length message))))))
370
371(define (process-status-message status reason)
372  (let ((message-with-reason
373	 (lambda (prefix connective)
374	   (if reason
375	       (string-append prefix
376			      (if connective (string-append " " connective) "")
377			      " "
378			      (number->string reason))
379	       prefix))))
380    (case status
381      ((RUN) "running")
382      ((STOP) (message-with-reason "stopped by signal" #f))
383      ((EXIT)
384       (if (zero? reason)
385	   "finished"
386	   (message-with-reason "exited abnormally" "with code")))
387      ((SIGNAL) (message-with-reason "terminated by signal" #f))
388      (else (error "illegal process status" status)))))
389
390(define (output-substring process string length)
391  (cond ((process-filter process)
392	 =>
393	 (lambda (filter)
394	   (filter process string 0 length)))
395	((process-mark process)
396	 =>
397	 (lambda (mark)
398	   (let ((index (mark-index mark)))
399	     (group-insert-substring! (mark-group mark) index string 0 length)
400	     (set-mark-index! mark (+ index length)))
401	   #t))
402	(else #f)))
403
404(define (add-process-filter process filter)
405  (let ((filter* (process-filter process)))
406    (if (filter-dispatcher? filter*)
407	(add-filter-to-dispatcher filter* filter)
408	(set-process-filter! process
409			     (make-filter-dispatcher (if filter*
410							 (list filter* filter)
411							 (list filter)))))))
412
413(define (remove-process-filter process filter)
414  (set-process-filter!
415   process
416   (let ((filter* (process-filter process)))
417     (cond ((eq? filter filter*) #f)
418	   ((filter-dispatcher? filter*)
419	    (remove-filter-from-dispatcher filter* filter))
420	   (else filter*)))))
421
422(define (make-filter-dispatcher filters)
423  (make-entity filter-dispatcher-procedure filters))
424
425(define (filter-dispatcher? object)
426  (and (entity? object)
427       (eq? filter-dispatcher-procedure (entity-procedure object))))
428
429(define (filter-dispatcher-procedure dispatcher process string start end)
430  (let loop ((filters (entity-extra dispatcher)))
431    (and (not (null? filters))
432	 (or ((car filters) process string start end)
433	     (loop (cdr filters))))))
434
435(define (add-filter-to-dispatcher dispatcher filter)
436  (let ((filters (entity-extra dispatcher)))
437    (if (pair? filters)
438	(set-cdr! (last-pair filters) (list filter))
439	(set-entity-extra! dispatcher (list filter)))))
440
441(define (remove-filter-from-dispatcher dispatcher filter)
442  (let ((filters (delq! filter (entity-extra dispatcher))))
443    (set-entity-extra! dispatcher filters)
444    (and (not (null? filters))
445	 dispatcher)))
446
447(define (standard-process-filter filter)
448  (lambda (process string start end)
449    (let ((mark (process-mark process)))
450      (and mark
451	   (begin
452	     (filter mark string start end)
453	     #t)))))
454
455;;;; Signals
456
457(define (signal-process process signal group?)
458  (let ((process (process-subprocess process)))
459    (let ((pty-master (and group? (subprocess-pty-master process))))
460      (if pty-master
461	  (pty-master-send-signal pty-master signal)
462	  (subprocess-signal process signal)))))
463
464(define (interrupt-process process group?)
465  (let ((process (process-subprocess process)))
466    (let ((pty-master (and group? (subprocess-pty-master process))))
467      (if pty-master
468	  (pty-master-interrupt pty-master)
469	  (subprocess-interrupt process)))))
470
471(define (quit-process process group?)
472  (let ((process (process-subprocess process)))
473    (let ((pty-master (and group? (subprocess-pty-master process))))
474      (if pty-master
475	  (pty-master-quit pty-master)
476	  (subprocess-quit process)))))
477
478(define (hangup-process process group?)
479  (let ((process (process-subprocess process)))
480    (let ((pty-master (and group? (subprocess-pty-master process))))
481      (if pty-master
482	  (pty-master-hangup pty-master)
483	  (subprocess-hangup process)))))
484
485(define (stop-process process group?)
486  (let ((process (process-subprocess process)))
487    (let ((pty-master (and group? (subprocess-pty-master process))))
488      (if pty-master
489	  (pty-master-stop pty-master)
490	  (subprocess-stop process)))))
491
492(define (continue-process process group?)
493  (let ((process (process-subprocess process)))
494    (let ((pty-master (and group? (subprocess-pty-master process))))
495      (if pty-master
496	  (pty-master-continue pty-master)
497	  (subprocess-continue-background process)))))
498
499(define (kill-process process group?)
500  (let ((process (process-subprocess process)))
501    (let ((pty-master (and group? (subprocess-pty-master process))))
502      (if pty-master
503	  (pty-master-kill pty-master)
504	  (subprocess-kill process)))))
505
506;;;; LIST-PROCESSES
507
508(define-command list-processes
509  "Display a list of all processes.
510\(Any processes listed as exited or signalled are actually eliminated
511after the listing is made.)"
512  ()
513  (lambda ()
514    (let ((buffer (temporary-buffer "*Process List*")))
515      (let ((point (buffer-point buffer)))
516	(let ((write-line
517	       (lambda (process status buffer command)
518		 (insert-string process point)
519		 (insert-horizontal-space 13 point)
520		 (insert-string status point)
521		 (insert-horizontal-space 24 point)
522		 (insert-string buffer point)
523		 (insert-horizontal-space 40 point)
524		 (insert-string command point)
525		 (insert-newline point))))
526	  (write-line "Process" "Status" "Buffer" "Command")
527	  (write-line "-------" "------" "------" "-------")
528	  (do ((processes edwin-processes (cdr processes)))
529	      ((null? processes))
530	    (let ((process (car processes)))
531	      (write-line (or (process-name process) "")
532			  (let ((status (process-status process)))
533			    (let ((name (symbol-name status)))
534			      (if (or (eq? 'EXIT status)
535				      (eq? 'SIGNAL status))
536				  (let ((reason (process-exit-reason process)))
537				    (delete-process process)
538				    (if (and (eq? 'EXIT status)
539					     (zero? reason))
540					name
541					(string-append
542					 name
543					 " "
544					 (number->string reason))))
545				  name)))
546			  (let ((buffer (process-buffer process)))
547			    (cond ((not buffer) "(none)")
548				  ((buffer-alive? buffer) (buffer-name buffer))
549				  (else "(killed)")))
550			  (process-arguments->string
551			   (process-arguments process)))))))
552      (set-buffer-point! buffer (buffer-start buffer))
553      (buffer-not-modified! buffer)
554      (pop-up-buffer buffer #f))))
555
556(define (process-arguments->string arguments)
557  (if (zero? (vector-length arguments))
558      ""
559      (apply string-append
560	     (let loop ((arguments (vector->list arguments)))
561	       (cons (car arguments)
562		     (if (null? (cdr arguments))
563			 '()
564			 (cons " " (loop (cdr arguments)))))))))
565
566(define (process-list)
567  (list-copy edwin-processes))
568
569;;;; Synchronous Subprocesses
570
571(define (run-synchronous-process input-region output-mark directory pty?
572				 program . arguments)
573  (let ((input-port
574	 (and input-region
575	      (make-buffer-input-port (region-start input-region)
576				      (region-end input-region))))
577	(output-port
578	 (and output-mark
579	      (mark->output-port
580	       (if (pair? output-mark) (car output-mark) output-mark)))))
581    (let ((result
582	   (run-synchronous-process-1 output-port
583	     (lambda ()
584	       (run-synchronous-subprocess
585		program arguments
586		'INPUT input-port
587		'OUTPUT output-port
588		'REDISPLAY-HOOK
589		(and (pair? output-mark)
590		     (cdr output-mark)
591		     (lambda () (update-screens! '(IGNORE-INPUT))))
592		'WORKING-DIRECTORY directory
593		'USE-PTY? pty?
594		'LINE-ENDING
595		(if (cond (input-region
596			   (ref-variable translate-file-data-on-output
597					 (region-start input-region)))
598			  (output-mark
599			   (ref-variable translate-file-data-on-input
600					 output-mark))
601			  (else #t))
602		    #f
603		    'NEWLINE)
604		)))))
605      (if input-port (close-port input-port))
606      (if output-port (close-port output-port))
607      result)))
608
609(define (run-synchronous-process-1 port thunk)
610  (call-with-current-continuation
611   (lambda (k)
612     (bind-condition-handler
613	 (list condition-type:subprocess-abnormal-termination)
614	 (lambda (condition)
615	   (if port
616	       (begin
617		 (fresh-line port)
618		 (newline port)
619		 (write-condition-report condition port)
620		 (newline port)))
621	   (k
622	    (cons (if (eq? condition-type:subprocess-stopped
623			   (condition/type condition))
624		      'STOPPED
625		      'SIGNALLED)
626		  (access-condition condition 'REASON))))
627       (lambda ()
628	 (let ((code (thunk)))
629	   (if (and port (not (= 0 code)))
630	       (begin
631		 (fresh-line port)
632		 (newline port)
633		 (write-string "Subprocess exited abnormally with code " port)
634		 (write code port)
635		 (write-string "." port)
636		 (newline port)))
637	   (cons 'EXITED code)))))))
638
639;;;; Shell Commands
640
641(define-command shell-command
642  "Execute string COMMAND in inferior shell; display output, if any.
643Optional second arg true (prefix arg, if interactive) means
644insert output in current buffer after point (leave mark after it)."
645  (lambda ()
646    (list (shell-command-prompt "Shell command")
647	  (command-argument)))
648  (lambda (command insert-at-point?)
649    (let ((directory (buffer-default-directory (current-buffer))))
650      (if insert-at-point?
651	  (begin
652	    (if (buffer-read-only? (current-buffer))
653		(barf-if-read-only))
654	    (let ((point (current-point)))
655	      (push-current-mark! point)
656	      (shell-command #f point directory #f command))
657	    ((ref-command exchange-point-and-mark)))
658	  (shell-command-pop-up-output
659	   (lambda (output-mark)
660	      (shell-command #f output-mark directory #f command)))))))
661
662(define-command shell-command-on-region
663  "Execute string COMMAND in inferior shell with region as input.
664Normally display output (if any) in temp buffer;
665Prefix arg means replace the region with it."
666  (lambda ()
667    (list (current-region)
668	  (shell-command-prompt "Shell command on region")
669	  (command-argument)))
670  (lambda (region command replace-region?)
671    (let ((directory (buffer-default-directory (current-buffer))))
672      (if replace-region?
673	  (let ((point (current-point))
674		(mark (current-mark)))
675	    (let ((swap? (mark< point mark))
676		  (temp))
677	      (dynamic-wind
678	       (lambda ()
679		 (set! temp (temporary-buffer " *shell-output*"))
680		 unspecific)
681	       (lambda ()
682		 (shell-command (make-region point mark)
683				(buffer-start temp)
684				directory
685				#f
686				command)
687		 (without-interrupts
688		  (lambda ()
689		    (delete-string point mark)
690		    (insert-region (buffer-start temp)
691				   (buffer-end temp)
692				   (current-point)))))
693	       (lambda ()
694		 (kill-buffer temp)
695		 (set! temp)
696		 unspecific))
697	      (if swap? ((ref-command exchange-point-and-mark)))))
698	  (shell-command-pop-up-output
699	   (lambda (output-mark)
700	     (shell-command region output-mark directory #f command)))))))
701
702(define (shell-command-prompt prompt)
703  (prompt-for-string prompt #f
704		     'DEFAULT-TYPE 'INSERTED-DEFAULT
705		     'HISTORY 'SHELL-COMMAND))
706
707(define (shell-command-pop-up-output generate-output)
708  (let ((buffer (temporary-buffer "*Shell Command Output*")))
709    (let ((start (buffer-start buffer)))
710      (generate-output start)
711      (set-buffer-point! buffer start)
712      (if (mark< start (buffer-end buffer))
713	  (pop-up-buffer buffer #f)
714	  (message "(Shell command completed with no output)")))))
715
716(define (shell-command input-region output-mark directory pty? command)
717  (apply run-synchronous-process
718	 input-region output-mark directory pty?
719	 (ref-variable shell-file-name)
720	 (os/form-shell-command command)))