459 lines
15 KiB
Scheme
459 lines
15 KiB
Scheme
#| -*-Scheme-*-
|
||
|
||
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
|
||
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
|
||
2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
|
||
2017, 2018, 2019, 2020 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
|
||
USA.
|
||
|
||
|#
|
||
|
||
;;;; Shell subprocess in a buffer
|
||
;;; Translated from "cmushell.el", by Olin Shivers.
|
||
|
||
|
||
|
||
(define-variable shell-prompt-pattern
|
||
"Regexp to match prompts in the inferior shell."
|
||
(os/default-shell-prompt-pattern)
|
||
string?)
|
||
|
||
(define-variable explicit-shell-file-name
|
||
"If not #F, file name to use for explicitly requested inferior shell."
|
||
#f
|
||
string-or-false?)
|
||
|
||
(define-major-mode shell comint "Shell"
|
||
"Major mode for interacting with an inferior shell.
|
||
Return after the end of the process' output sends the text from the
|
||
end of process to the end of the current line.
|
||
Return before end of process output copies rest of line to end (skipping
|
||
the prompt) and sends it.
|
||
|
||
If you accidentally suspend your process, use \\[comint-continue-subjob]
|
||
to continue it.
|
||
|
||
cd, pushd and popd commands given to the shell are watched to keep
|
||
this buffer's default directory the same as the shell's working directory.
|
||
\\[shell-resync-dirs] queries the shell and resyncs Edwin's idea of what the
|
||
current directory stack is.
|
||
\\[shell-dirtrack-toggle] turns directory tracking on and off.
|
||
|
||
\\{shell}
|
||
Customisation: Entry to this mode runs the hooks on comint-mode-hook and
|
||
shell-mode-hook (in that order).
|
||
|
||
Variables shell-cd-regexp, shell-pushd-regexp and shell-popd-regexp are used
|
||
to match their respective commands."
|
||
(lambda (buffer)
|
||
(local-set-variable! comint-prompt-regexp
|
||
(ref-variable shell-prompt-pattern buffer)
|
||
buffer)
|
||
(local-set-variable! comint-dynamic-complete-functions
|
||
(list shell-dynamic-complete-command
|
||
comint-dynamic-complete-filename)
|
||
buffer)
|
||
(local-set-variable! comint-input-sentinel shell-directory-tracker buffer)
|
||
(local-set-variable! shell-dirstack '() buffer)
|
||
(local-set-variable! shell-dirtrack? #t buffer)
|
||
(local-set-variable! local-abbrev-table
|
||
(ref-variable shell-mode-abbrev-table buffer)
|
||
buffer)
|
||
(event-distributor/invoke! (ref-variable shell-mode-hook buffer) buffer)))
|
||
|
||
(define-variable shell-mode-abbrev-table
|
||
"Mode-specific abbrev table for Shell mode.")
|
||
(define-abbrev-table 'shell-mode-abbrev-table '())
|
||
|
||
(define-variable shell-mode-hook
|
||
"An event distributor that is invoked when entering Shell mode."
|
||
(make-event-distributor))
|
||
|
||
(define-key 'shell #\tab 'comint-dynamic-complete)
|
||
(define-key 'shell #\M-? 'comint-dynamic-list-completions)
|
||
|
||
(define-command shell
|
||
"Run an inferior shell, with I/O through buffer *shell*.
|
||
With prefix argument, unconditionally create a new buffer and process.
|
||
If buffer exists but shell process is not running, make new shell.
|
||
If buffer exists and shell process is running, just switch to buffer *shell*.
|
||
|
||
The shell to use comes from the first non-#f variable found from these:
|
||
explicit-shell-file-name in Edwin, ESHELL in the environment or
|
||
shell-file-name in Edwin.
|
||
|
||
The buffer is put in Shell mode, giving commands for sending input
|
||
and controlling the subjobs of the shell.
|
||
|
||
The shell file name (sans directories) is used to make a symbol name
|
||
such as `explicit-csh-arguments'. If that symbol is a variable,
|
||
its value is used as a list of arguments when invoking the shell.
|
||
Otherwise, one argument `-i' is passed to the shell."
|
||
"P"
|
||
(lambda (new-buffer?)
|
||
(select-buffer
|
||
(let ((program
|
||
(or (ref-variable explicit-shell-file-name)
|
||
(get-environment-variable "ESHELL")
|
||
(ref-variable shell-file-name))))
|
||
(apply make-comint
|
||
(ref-mode-object shell)
|
||
(if (not new-buffer?) "*shell*" (new-buffer "*shell*"))
|
||
program
|
||
(let ((variable
|
||
(string-table-get editor-variables
|
||
(string-append "explicit-"
|
||
(os/shell-name program)
|
||
"-args"))))
|
||
(if variable
|
||
(variable-value variable)
|
||
(os/default-shell-args))))))))
|
||
|
||
;;;; Directory Tracking
|
||
|
||
(define-variable shell-popd-regexp
|
||
"Regexp to match subshell commands equivalent to popd."
|
||
"popd")
|
||
|
||
(define-variable shell-pushd-regexp
|
||
"Regexp to match subshell commands equivalent to pushd."
|
||
"pushd")
|
||
|
||
(define-variable shell-cd-regexp
|
||
"Regexp to match subshell commands equivalent to cd."
|
||
"cd")
|
||
|
||
(define-variable shell-dirstack-query
|
||
"Command used by shell-resync-dirs to query shell."
|
||
"dirs")
|
||
|
||
(define-variable shell-dirstack
|
||
"List of directories saved by pushd in this buffer's shell."
|
||
'())
|
||
|
||
(define-variable shell-dirtrack? "" #f)
|
||
|
||
(define (shell-directory-tracker string)
|
||
(if (ref-variable shell-dirtrack?)
|
||
(let ((start
|
||
(let ((r
|
||
(re-string-match "^\\s *" string #f
|
||
(ref-variable syntax-table))))
|
||
(if r
|
||
(re-match-end-index 0 r)
|
||
0)))
|
||
(end (string-length string)))
|
||
(let ((try
|
||
(let ((match
|
||
(lambda (regexp start)
|
||
(re-substring-match regexp
|
||
string start end
|
||
#f
|
||
(ref-variable syntax-table)))))
|
||
(lambda (command)
|
||
(let ((eoc
|
||
(let ((r (match command start)))
|
||
(and r
|
||
(re-match-end-index 0 r)))))
|
||
(cond ((not eoc) #f)
|
||
((match "\\s *\\(\;\\|$\\)" eoc) "")
|
||
((match "\\s +\\([^ \t\;]+\\)\\s *\\(\;\\|$\\)" eoc)
|
||
=> (lambda (r)
|
||
(substring string
|
||
(re-match-start-index 1 r)
|
||
(re-match-end-index 1 r))))
|
||
(else #f)))))))
|
||
(cond ((try (ref-variable shell-cd-regexp))
|
||
=> shell-process-cd)
|
||
((try (ref-variable shell-pushd-regexp))
|
||
=> shell-process-pushd)
|
||
((try (ref-variable shell-popd-regexp))
|
||
=> shell-process-popd))))))
|
||
|
||
(define (shell-process-pushd arg)
|
||
(let ((default-directory
|
||
(->namestring (buffer-default-directory (current-buffer))))
|
||
(dirstack (ref-variable shell-dirstack)))
|
||
(if (string-null? arg)
|
||
;; no arg -- swap pwd and car of shell stack
|
||
(if (null? dirstack)
|
||
(message "Directory stack empty")
|
||
(begin
|
||
(set-variable! shell-dirstack
|
||
(cons default-directory (cdr dirstack)))
|
||
(shell-process-cd (car dirstack))))
|
||
(let ((num (shell-extract-num arg)))
|
||
(if num ; pushd +n
|
||
(if (> num (length dirstack))
|
||
(message "Directory stack not that deep")
|
||
(let ((dirstack
|
||
(let ((dirstack (cons default-directory dirstack)))
|
||
(append (drop dirstack num)
|
||
(take dirstack (- (length dirstack) num))))))
|
||
(set-variable! shell-dirstack (cdr dirstack))
|
||
(shell-process-cd (car dirstack))))
|
||
(begin
|
||
(set-variable! shell-dirstack
|
||
(cons default-directory dirstack))
|
||
(shell-process-cd arg)))))))
|
||
|
||
(define (shell-process-popd arg)
|
||
(let ((dirstack (ref-variable shell-dirstack))
|
||
(num
|
||
(if (string-null? arg)
|
||
0
|
||
(shell-extract-num arg))))
|
||
(cond ((not num)
|
||
(message "Bad popd"))
|
||
((>= num (length dirstack))
|
||
(message "Directory stack empty"))
|
||
((= num 0)
|
||
(set-variable! shell-dirstack (cdr dirstack))
|
||
(shell-process-cd (car dirstack)))
|
||
(else
|
||
(if (= num 1)
|
||
(set-variable! shell-dirstack (cdr dirstack))
|
||
(let ((pair (drop dirstack (- num 1))))
|
||
(set-cdr! pair (cddr pair))))
|
||
(shell-dirstack-message)))))
|
||
|
||
(define (shell-extract-num string)
|
||
(and (re-string-match "^\\+[1-9][0-9]*$" string)
|
||
(string->number string)))
|
||
|
||
(define (shell-process-cd filename)
|
||
(call-with-current-continuation
|
||
(lambda (continuation)
|
||
(bind-condition-handler (list condition-type:editor-error)
|
||
(lambda (condition)
|
||
(apply message (editor-error-strings condition))
|
||
(continuation unspecific))
|
||
(lambda ()
|
||
(set-default-directory
|
||
(if (string-null? filename)
|
||
(user-homedir-pathname)
|
||
filename))))))
|
||
(shell-dirstack-message))
|
||
|
||
(define (shell-dirstack-message)
|
||
(apply message
|
||
(let loop
|
||
((dirs
|
||
(cons (buffer-default-directory (current-buffer))
|
||
(ref-variable shell-dirstack))))
|
||
(cons (os/pathname->display-string (car dirs))
|
||
(if (null? (cdr dirs))
|
||
'()
|
||
(cons " " (loop (cdr dirs))))))))
|
||
|
||
(define-command shell-dirtrack-toggle
|
||
"Turn directory tracking on and off in a shell buffer."
|
||
"P"
|
||
(lambda (argument)
|
||
(set-variable!
|
||
shell-dirtrack?
|
||
(let ((argument (command-argument-value argument)))
|
||
(cond ((not argument) (not (ref-variable shell-dirtrack?)))
|
||
((positive? argument) #t)
|
||
((negative? argument) #f)
|
||
(else (ref-variable shell-dirtrack?)))))
|
||
(message "Directory tracking "
|
||
(if (ref-variable shell-dirtrack?) "on" "off")
|
||
".")))
|
||
|
||
(define-command shell-resync-dirs
|
||
"Resync the buffer's idea of the current directory stack.
|
||
This command queries the shell with the command bound to
|
||
shell-dirstack-query (default \"dirs\"), reads the next
|
||
line output and parses it to form the new directory stack.
|
||
DON'T issue this command unless the buffer is at a shell prompt.
|
||
Also, note that if some other subprocess decides to do output
|
||
immediately after the query, its output will be taken as the
|
||
new directory stack -- you lose. If this happens, just do the
|
||
command again."
|
||
()
|
||
(lambda ()
|
||
(let ((process (current-process)))
|
||
(let ((mark (process-mark process)))
|
||
(set-current-point! mark)
|
||
(let ((pending-input
|
||
;; Kill any pending input.
|
||
(extract-and-delete-string mark (group-end mark)))
|
||
(point (mark-left-inserting-copy (current-point))))
|
||
;; Insert the command, then send it to the shell.
|
||
(let ((dirstack-query (ref-variable shell-dirstack-query)))
|
||
(insert-string dirstack-query point)
|
||
(move-mark-to! (ref-variable comint-last-input-end) point)
|
||
(insert-newline point)
|
||
(move-mark-to! mark point)
|
||
(process-send-string process (string-append dirstack-query "\n")))
|
||
;; Wait for a line of output.
|
||
(let ((output-line
|
||
(let ((output-start (mark-right-inserting-copy point)))
|
||
(do ()
|
||
((re-match-forward ".*\n" output-start)
|
||
(mark-temporary! output-start)
|
||
(extract-string (re-match-start 0)
|
||
(mark-1+ (re-match-end 0))))
|
||
(accept-process-output)))))
|
||
;; Restore any pending input.
|
||
(insert-string pending-input point)
|
||
(mark-temporary! point)
|
||
(let ((dirlist (shell-tokenize-dirlist output-line)))
|
||
(set-variable! shell-dirstack (cdr dirlist))
|
||
(shell-process-cd (car dirlist)))))))))
|
||
|
||
(define (shell-tokenize-dirlist string)
|
||
(let ((end (string-length string)))
|
||
(let skip-spaces ((start 0))
|
||
(cond ((= start end)
|
||
'())
|
||
((char=? #\space (string-ref string start))
|
||
(skip-spaces (+ start 1)))
|
||
(else
|
||
(let skip-nonspaces ((index (+ start 1)))
|
||
(cond ((= index end)
|
||
(list (substring string start end)))
|
||
((char=? #\space (string-ref string index))
|
||
(cons (substring string start index)
|
||
(skip-spaces (+ index 1))))
|
||
(else
|
||
(skip-nonspaces (+ index 1))))))))))
|
||
|
||
;;;; Command Completion
|
||
|
||
(define-variable shell-command-regexp
|
||
"Regexp to match a single command within a pipeline.
|
||
This is used for command completion and does not do a perfect job."
|
||
(os/shell-command-regexp)
|
||
string?)
|
||
|
||
(define-variable shell-completion-execonly
|
||
"If true, use executable files only for completion candidates.
|
||
This mirrors the optional behavior of tcsh.
|
||
|
||
Detecting executability of files may slow command completion considerably."
|
||
#t
|
||
boolean?)
|
||
|
||
(define (shell-backward-command mark n)
|
||
(and (> n 0)
|
||
(let ((limit
|
||
(let ((limit (comint-line-start mark)))
|
||
(if (mark> limit mark)
|
||
(line-start mark 0)
|
||
limit)))
|
||
(regexp
|
||
(string-append "["
|
||
(os/shell-command-separators)
|
||
"]+[\t ]*\\("
|
||
(ref-variable shell-command-regexp mark)
|
||
"\\)")))
|
||
(let loop
|
||
((mark
|
||
(let ((m (re-search-backward "\\S " mark limit #f)))
|
||
(if m
|
||
(mark1+ m)
|
||
limit)))
|
||
(n n))
|
||
(let ((mark* (re-search-backward regexp mark limit #f))
|
||
(n (- n 1)))
|
||
(if mark*
|
||
(if (> n 0)
|
||
(loop mark* (- n 1))
|
||
(skip-chars-forward (os/shell-command-separators)
|
||
(re-match-start 1)))
|
||
limit))))))
|
||
|
||
(define (shell-dynamic-complete-command)
|
||
"Dynamically complete the command at point.
|
||
This function is similar to `comint-dynamic-complete-filename', except that it
|
||
searches the PATH environment variable for completion candidates.
|
||
Note that this may not be the same as the shell's idea of the path.
|
||
|
||
Completion is dependent on the value of `shell-completion-execonly', plus
|
||
those that effect file completion."
|
||
(let ((r (comint-current-filename-region)))
|
||
(and (not (mark= (region-start r) (region-end r)))
|
||
(string=? "" (directory-namestring (region->string r)))
|
||
(let ((m (shell-backward-command (current-point) 1)))
|
||
(and m
|
||
(mark= (region-start r) m)))
|
||
(begin
|
||
(message "Completing command name...")
|
||
(standard-completion (region->string r)
|
||
(lambda (filename if-unique if-not-unique if-not-found)
|
||
(shell-complete-command
|
||
(parse-namestring filename)
|
||
(ref-variable shell-completion-execonly (region-start r))
|
||
if-unique if-not-unique if-not-found))
|
||
(lambda (filename)
|
||
(region-delete! r)
|
||
(insert-string filename (region-start r))))))))
|
||
|
||
(define (shell-complete-command command exec-only?
|
||
if-unique if-not-unique if-not-found)
|
||
(let* ((results '())
|
||
(maybe-add-filename!
|
||
(let ((add-filename!
|
||
(lambda (filename)
|
||
(let ((s (file-namestring filename)))
|
||
(if (not (member s results))
|
||
(set! results (cons s results))))
|
||
unspecific)))
|
||
(if exec-only?
|
||
(lambda (filename)
|
||
(if (file-executable? filename)
|
||
(add-filename! filename)))
|
||
add-filename!))))
|
||
(for-each
|
||
(lambda (directory)
|
||
(filename-complete-string (merge-pathnames command directory)
|
||
maybe-add-filename!
|
||
(lambda (common get-completions)
|
||
(let ((directory (directory-pathname common)))
|
||
(for-each
|
||
(lambda (filename)
|
||
(maybe-add-filename! (merge-pathnames directory filename)))
|
||
(get-completions))))
|
||
(lambda () unspecific)))
|
||
(os/parse-path-string (get-environment-variable "PATH")))
|
||
(cond ((null? results)
|
||
(if-not-found))
|
||
((null? (cdr results))
|
||
(if-unique
|
||
(let ((result (car results)))
|
||
(if (member (pathname-type result)
|
||
(os/executable-pathname-types))
|
||
(->namestring (pathname-new-type result #f))
|
||
result))))
|
||
(else
|
||
(if-not-unique (compute-max-prefix results) (lambda () results))))
|
||
(not (null? results))))
|
||
|
||
(define (compute-max-prefix strings)
|
||
(let loop ((prefix (car strings)) (strings (cdr strings)))
|
||
(if (null? strings)
|
||
prefix
|
||
(loop (let ((n (string-match-forward prefix (car strings))))
|
||
(if (fix:< n (string-length prefix))
|
||
(string-head prefix n)
|
||
prefix))
|
||
(cdr strings)))))
|