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;;;; Shell subprocess in a buffer
28;;; Translated from "cmushell.el", by Olin Shivers.
29
30(declare (usual-integrations))
31
32(define-variable shell-prompt-pattern
33  "Regexp to match prompts in the inferior shell."
34  (os/default-shell-prompt-pattern)
35  string?)
36
37(define-variable explicit-shell-file-name
38  "If not #F, file name to use for explicitly requested inferior shell."
39  #f
40  string-or-false?)
41
42(define-major-mode shell comint "Shell"
43  "Major mode for interacting with an inferior shell.
44Return after the end of the process' output sends the text from the
45    end of process to the end of the current line.
46Return before end of process output copies rest of line to end (skipping
47    the prompt) and sends it.
48
49If you accidentally suspend your process, use \\[comint-continue-subjob]
50to continue it.
51
52cd, pushd and popd commands given to the shell are watched to keep
53this buffer's default directory the same as the shell's working directory.
54\\[shell-resync-dirs] queries the shell and resyncs Edwin's idea of what the
55    current directory stack is.
56\\[shell-dirtrack-toggle] turns directory tracking on and off.
57
58\\{shell}
59Customisation: Entry to this mode runs the hooks on comint-mode-hook and
60shell-mode-hook (in that order).
61
62Variables shell-cd-regexp, shell-pushd-regexp and shell-popd-regexp are used
63to match their respective commands."
64  (lambda (buffer)
65    (local-set-variable! comint-prompt-regexp
66			 (ref-variable shell-prompt-pattern buffer)
67			 buffer)
68    (local-set-variable! comint-dynamic-complete-functions
69			 (list shell-dynamic-complete-command
70			       comint-dynamic-complete-filename)
71			 buffer)
72    (local-set-variable! comint-input-sentinel shell-directory-tracker buffer)
73    (local-set-variable! shell-dirstack '() buffer)
74    (local-set-variable! shell-dirtrack? #t buffer)
75    (local-set-variable! local-abbrev-table
76			 (ref-variable shell-mode-abbrev-table buffer)
77			 buffer)
78    (event-distributor/invoke! (ref-variable shell-mode-hook buffer) buffer)))
79
80(define-variable shell-mode-abbrev-table
81  "Mode-specific abbrev table for Shell mode.")
82(define-abbrev-table 'shell-mode-abbrev-table '())
83
84(define-variable shell-mode-hook
85  "An event distributor that is invoked when entering Shell mode."
86  (make-event-distributor))
87
88(define-key 'shell #\tab 'comint-dynamic-complete)
89(define-key 'shell #\M-? 'comint-dynamic-list-completions)
90
91(define-command shell
92  "Run an inferior shell, with I/O through buffer *shell*.
93With prefix argument, unconditionally create a new buffer and process.
94If buffer exists but shell process is not running, make new shell.
95If buffer exists and shell process is running, just switch to buffer *shell*.
96
97The shell to use comes from the first non-#f variable found from these:
98explicit-shell-file-name in Edwin, ESHELL in the environment or
99shell-file-name in Edwin.
100
101The buffer is put in Shell mode, giving commands for sending input
102and controlling the subjobs of the shell.
103
104The shell file name (sans directories) is used to make a symbol name
105such as `explicit-csh-arguments'.  If that symbol is a variable,
106its value is used as a list of arguments when invoking the shell.
107Otherwise, one argument `-i' is passed to the shell."
108  "P"
109  (lambda (new-buffer?)
110    (select-buffer
111     (let ((program
112	    (or (ref-variable explicit-shell-file-name)
113		(get-environment-variable "ESHELL")
114		(ref-variable shell-file-name))))
115       (apply make-comint
116	      (ref-mode-object shell)
117	      (if (not new-buffer?) "*shell*" (new-buffer "*shell*"))
118	      program
119	      (let ((variable
120		     (string-table-get editor-variables
121				       (string-append "explicit-"
122						      (os/shell-name program)
123						      "-args"))))
124		(if variable
125		    (variable-value variable)
126		    (os/default-shell-args))))))))
127
128;;;; Directory Tracking
129
130(define-variable shell-popd-regexp
131  "Regexp to match subshell commands equivalent to popd."
132  "popd")
133
134(define-variable shell-pushd-regexp
135  "Regexp to match subshell commands equivalent to pushd."
136  "pushd")
137
138(define-variable shell-cd-regexp
139  "Regexp to match subshell commands equivalent to cd."
140  "cd")
141
142(define-variable shell-dirstack-query
143  "Command used by shell-resync-dirs to query shell."
144  "dirs")
145
146(define-variable shell-dirstack
147  "List of directories saved by pushd in this buffer's shell."
148  '())
149
150(define-variable shell-dirtrack? "" #f)
151
152(define (shell-directory-tracker string)
153  (if (ref-variable shell-dirtrack?)
154      (let ((start
155	     (let ((r
156		    (re-string-match "^\\s *" string #f
157				     (ref-variable syntax-table))))
158	       (if r
159		   (re-match-end-index 0 r)
160		   0)))
161	    (end (string-length string)))
162	(let ((try
163	       (let ((match
164		      (lambda (regexp start)
165			(re-substring-match regexp
166					    string start end
167					    #f
168					    (ref-variable syntax-table)))))
169		 (lambda (command)
170		   (let ((eoc
171			  (let ((r (match command start)))
172			    (and r
173				 (re-match-end-index 0 r)))))
174		     (cond ((not eoc) #f)
175			   ((match "\\s *\\(\;\\|$\\)" eoc) "")
176			   ((match "\\s +\\([^ \t\;]+\\)\\s *\\(\;\\|$\\)" eoc)
177			    => (lambda (r)
178				 (substring string
179					    (re-match-start-index 1 r)
180					    (re-match-end-index 1 r))))
181			   (else #f)))))))
182	  (cond ((try (ref-variable shell-cd-regexp))
183		 => shell-process-cd)
184		((try (ref-variable shell-pushd-regexp))
185		 => shell-process-pushd)
186		((try (ref-variable shell-popd-regexp))
187		 => shell-process-popd))))))
188
189(define (shell-process-pushd arg)
190  (let ((default-directory
191	  (->namestring (buffer-default-directory (current-buffer))))
192	(dirstack (ref-variable shell-dirstack)))
193    (if (string-null? arg)
194	;; no arg -- swap pwd and car of shell stack
195	(if (null? dirstack)
196	    (message "Directory stack empty")
197	    (begin
198	      (set-variable! shell-dirstack
199			     (cons default-directory (cdr dirstack)))
200	      (shell-process-cd (car dirstack))))
201	(let ((num (shell-extract-num arg)))
202	  (if num			; pushd +n
203	      (if (> num (length dirstack))
204		  (message "Directory stack not that deep")
205		  (let ((dirstack
206			 (let ((dirstack (cons default-directory dirstack)))
207			   (append (list-tail dirstack num)
208				   (list-head dirstack
209					      (- (length dirstack) num))))))
210		    (set-variable! shell-dirstack (cdr dirstack))
211		    (shell-process-cd (car dirstack))))
212	      (begin
213		(set-variable! shell-dirstack
214			       (cons default-directory dirstack))
215		(shell-process-cd arg)))))))
216
217(define (shell-process-popd arg)
218  (let ((dirstack (ref-variable shell-dirstack))
219	(num
220	 (if (string-null? arg)
221	     0
222	     (shell-extract-num arg))))
223    (cond ((not num)
224	   (message "Bad popd"))
225	  ((>= num (length dirstack))
226	   (message "Directory stack empty"))
227	  ((= num 0)
228	   (set-variable! shell-dirstack (cdr dirstack))
229	   (shell-process-cd (car dirstack)))
230	  (else
231	   (if (= num 1)
232	       (set-variable! shell-dirstack (cdr dirstack))
233	       (let ((pair (list-tail dirstack (- num 1))))
234		 (set-cdr! pair (cddr pair))))
235	   (shell-dirstack-message)))))
236
237(define (shell-extract-num string)
238  (and (re-string-match "^\\+[1-9][0-9]*$" string)
239       (string->number string)))
240
241(define (shell-process-cd filename)
242  (call-with-current-continuation
243   (lambda (continuation)
244     (bind-condition-handler (list condition-type:editor-error)
245	 (lambda (condition)
246	   (apply message (editor-error-strings condition))
247	   (continuation unspecific))
248       (lambda ()
249	 (set-default-directory
250	  (if (string-null? filename)
251	      (user-homedir-pathname)
252	      filename))))))
253  (shell-dirstack-message))
254
255(define (shell-dirstack-message)
256  (apply message
257	 (let loop
258	     ((dirs
259	       (cons (buffer-default-directory (current-buffer))
260		     (ref-variable shell-dirstack))))
261	   (cons (os/pathname->display-string (car dirs))
262		 (if (null? (cdr dirs))
263		     '()
264		     (cons " " (loop (cdr dirs))))))))
265
266(define-command shell-dirtrack-toggle
267  "Turn directory tracking on and off in a shell buffer."
268  "P"
269  (lambda (argument)
270    (set-variable!
271     shell-dirtrack?
272     (let ((argument (command-argument-value argument)))
273       (cond ((not argument) (not (ref-variable shell-dirtrack?)))
274	     ((positive? argument) #t)
275	     ((negative? argument) #f)
276	     (else (ref-variable shell-dirtrack?)))))
277    (message "Directory tracking "
278	     (if (ref-variable shell-dirtrack?) "on" "off")
279	     ".")))
280
281(define-command shell-resync-dirs
282  "Resync the buffer's idea of the current directory stack.
283This command queries the shell with the command bound to
284shell-dirstack-query (default \"dirs\"), reads the next
285line output and parses it to form the new directory stack.
286DON'T issue this command unless the buffer is at a shell prompt.
287Also, note that if some other subprocess decides to do output
288immediately after the query, its output will be taken as the
289new directory stack -- you lose.  If this happens, just do the
290command again."
291  ()
292  (lambda ()
293    (let ((process (current-process)))
294      (let ((mark (process-mark process)))
295	(set-current-point! mark)
296	(let ((pending-input
297	       ;; Kill any pending input.
298	       (extract-and-delete-string mark (group-end mark)))
299	      (point (mark-left-inserting-copy (current-point))))
300	  ;; Insert the command, then send it to the shell.
301	  (let ((dirstack-query (ref-variable shell-dirstack-query)))
302	    (insert-string dirstack-query point)
303	    (move-mark-to! (ref-variable comint-last-input-end) point)
304	    (insert-newline point)
305	    (move-mark-to! mark point)
306	    (process-send-string process (string-append dirstack-query "\n")))
307	  ;; Wait for a line of output.
308	  (let ((output-line
309		 (let ((output-start (mark-right-inserting-copy point)))
310		   (do ()
311		       ((re-match-forward ".*\n" output-start)
312			(mark-temporary! output-start)
313			(extract-string (re-match-start 0)
314					(mark-1+ (re-match-end 0))))
315		     (accept-process-output)))))
316	    ;; Restore any pending input.
317	    (insert-string pending-input point)
318	    (mark-temporary! point)
319	    (let ((dirlist (shell-tokenize-dirlist output-line)))
320	      (set-variable! shell-dirstack (cdr dirlist))
321	      (shell-process-cd (car dirlist)))))))))
322
323(define (shell-tokenize-dirlist string)
324  (let ((end (string-length string)))
325    (let skip-spaces ((start 0))
326      (cond ((= start end)
327	     '())
328	    ((char=? #\space (string-ref string start))
329	     (skip-spaces (+ start 1)))
330	    (else
331	     (let skip-nonspaces ((index (+ start 1)))
332	       (cond ((= index end)
333		      (list (substring string start end)))
334		     ((char=? #\space (string-ref string index))
335		      (cons (substring string start index)
336			    (skip-spaces (+ index 1))))
337		     (else
338		      (skip-nonspaces (+ index 1))))))))))
339
340;;;; Command Completion
341
342(define-variable shell-command-regexp
343  "Regexp to match a single command within a pipeline.
344This is used for command completion and does not do a perfect job."
345  (os/shell-command-regexp)
346  string?)
347
348(define-variable shell-completion-execonly
349  "If true, use executable files only for completion candidates.
350This mirrors the optional behavior of tcsh.
351
352Detecting executability of files may slow command completion considerably."
353  #t
354  boolean?)
355
356(define (shell-backward-command mark n)
357  (and (> n 0)
358       (let ((limit
359	      (let ((limit (comint-line-start mark)))
360		(if (mark> limit mark)
361		    (line-start mark 0)
362		    limit)))
363	     (regexp
364	      (string-append "["
365			     (os/shell-command-separators)
366			     "]+[\t ]*\\("
367			     (ref-variable shell-command-regexp mark)
368			     "\\)")))
369	 (let loop
370	     ((mark
371	       (let ((m (re-search-backward "\\S " mark limit #f)))
372		 (if m
373		     (mark1+ m)
374		     limit)))
375	      (n n))
376	   (let ((mark* (re-search-backward regexp mark limit #f))
377		 (n (- n 1)))
378	     (if mark*
379		 (if (> n 0)
380		     (loop mark* (- n 1))
381		     (skip-chars-forward (os/shell-command-separators)
382					 (re-match-start 1)))
383		 limit))))))
384
385(define (shell-dynamic-complete-command)
386  "Dynamically complete the command at point.
387This function is similar to `comint-dynamic-complete-filename', except that it
388searches the PATH environment variable for completion candidates.
389Note that this may not be the same as the shell's idea of the path.
390
391Completion is dependent on the value of `shell-completion-execonly', plus
392those that effect file completion."
393  (let ((r (comint-current-filename-region)))
394    (and (not (mark= (region-start r) (region-end r)))
395	 (string=? "" (directory-namestring (region->string r)))
396	 (let ((m (shell-backward-command (current-point) 1)))
397	   (and m
398		(mark= (region-start r) m)))
399	 (begin
400	   (message "Completing command name...")
401	   (standard-completion (region->string r)
402	     (lambda (filename if-unique if-not-unique if-not-found)
403	       (shell-complete-command
404		(parse-namestring filename)
405		(ref-variable shell-completion-execonly (region-start r))
406		if-unique if-not-unique if-not-found))
407	     (lambda (filename)
408	       (region-delete! r)
409	       (insert-string filename (region-start r))))))))
410
411(define (shell-complete-command command exec-only?
412				if-unique if-not-unique if-not-found)
413  (let* ((results '())
414	 (maybe-add-filename!
415	  (let ((add-filename!
416		 (lambda (filename)
417		   (let ((s (file-namestring filename)))
418		     (if (not (member s results))
419			 (set! results (cons s results))))
420		   unspecific)))
421	    (if exec-only?
422		(lambda (filename)
423		  (if (file-executable? filename)
424		      (add-filename! filename)))
425		add-filename!))))
426    (for-each
427     (lambda (directory)
428       (filename-complete-string (merge-pathnames command directory)
429	 maybe-add-filename!
430	 (lambda (common get-completions)
431	   (let ((directory (directory-pathname common)))
432	     (for-each
433	      (lambda (filename)
434		(maybe-add-filename! (merge-pathnames directory filename)))
435	      (get-completions))))
436	 (lambda () unspecific)))
437     (os/parse-path-string (get-environment-variable "PATH")))
438    (cond ((null? results)
439	   (if-not-found))
440	  ((null? (cdr results))
441	   (if-unique
442	    (let ((result (car results)))
443	      (if (member (pathname-type result)
444			  (os/executable-pathname-types))
445		  (->namestring (pathname-new-type result #f))
446		  result))))
447	  (else
448	   (if-not-unique (compute-max-prefix results) (lambda () results))))
449    (not (null? results))))
450
451(define (compute-max-prefix strings)
452  (let loop ((prefix (car strings)) (strings (cdr strings)))
453    (if (null? strings)
454	prefix
455	(loop (let ((n (string-match-forward prefix (car strings))))
456		(if (fix:< n (string-length prefix))
457		    (string-head prefix n)
458		    prefix))
459	      (cdr strings)))))