2021-04-26 07:53:20 -04:00
|
|
|
|
#| -*-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.
|
|
|
|
|
|
|
|
|
|
|#
|
|
|
|
|
|
|
|
|
|
;;;; Pseudo Shell subprocess in a buffer
|
|
|
|
|
;;; Inspired by "cmushell.el", by Olin Shivers.
|
|
|
|
|
|
2021-04-26 07:57:47 -04:00
|
|
|
|
|
2021-04-26 07:53:20 -04:00
|
|
|
|
|
|
|
|
|
(load-option 'DOSPROCESS)
|
|
|
|
|
|
|
|
|
|
(define-major-mode pseudo-shell fundamental "Pseudo Shell"
|
|
|
|
|
"Major mode for executing DOS commands.
|
|
|
|
|
Return executes the current line as a DOS command.
|
|
|
|
|
Output is inserted into the buffer after the command.
|
|
|
|
|
There is currently no way to send input interactively to the command.
|
|
|
|
|
Use \\[shell-command-on-region] to feed input to the command.
|
|
|
|
|
|
|
|
|
|
cd, pushd, and popd commands are not executed as commands (they would have
|
|
|
|
|
no effect) but emulated directly by Edwin.
|
|
|
|
|
|
|
|
|
|
Customization: Entry to this mode runs the hook pseudo-shell-mode-hook."
|
|
|
|
|
(lambda (buffer)
|
|
|
|
|
(define-variable-local-value! buffer
|
|
|
|
|
(ref-variable-object pseudo-shell-dirstack)
|
|
|
|
|
'())
|
|
|
|
|
(define-variable-local-value! buffer
|
|
|
|
|
(ref-variable-object pseudo-shell-dirtrack?)
|
|
|
|
|
true)
|
|
|
|
|
(define-variable-local-value! buffer
|
|
|
|
|
(ref-variable-object comint-input-ring)
|
|
|
|
|
(make-ring (ref-variable comint-input-ring-size)))
|
|
|
|
|
(define-variable-local-value! buffer
|
|
|
|
|
(ref-variable-object comint-last-input-match)
|
|
|
|
|
false)
|
|
|
|
|
(define-variable-local-value! buffer
|
|
|
|
|
(ref-variable-object pseudo-shell-active?)
|
|
|
|
|
true)
|
|
|
|
|
(event-distributor/invoke! (ref-variable pseudo-shell-mode-hook)
|
|
|
|
|
buffer)))
|
|
|
|
|
|
|
|
|
|
(define-variable pseudo-shell-mode-hook
|
|
|
|
|
"An event distributor that is invoked when entering Pseudo Shell mode."
|
|
|
|
|
(make-event-distributor))
|
|
|
|
|
|
|
|
|
|
(define-variable pseudo-shell-active?
|
|
|
|
|
"Is this shell buffer active?"
|
|
|
|
|
false
|
|
|
|
|
boolean?)
|
|
|
|
|
|
|
|
|
|
(define-key 'pseudo-shell #\C-a 'pseudo-shell-bol)
|
|
|
|
|
(define-key 'pseudo-shell #\C-m 'pseudo-shell-execute-command)
|
|
|
|
|
|
|
|
|
|
(define-key 'pseudo-shell #\M-p 'comint-previous-input)
|
|
|
|
|
(define-key 'pseudo-shell #\M-n 'comint-next-input)
|
|
|
|
|
(define-key 'pseudo-shell '(#\C-c #\C-r) 'comint-history-search-backward)
|
|
|
|
|
(define-key 'pseudo-shell '(#\C-c #\C-s) 'comint-history-search-forward)
|
|
|
|
|
(define-key 'pseudo-shell '(#\C-c #\C-w) 'backward-kill-word)
|
|
|
|
|
|
|
|
|
|
;; (define-key 'pseudo-shell #\tab 'comint-dynamic-complete)
|
|
|
|
|
;; (define-key 'pseudo-shell #\M-? 'comint-dynamic-list-completions)
|
|
|
|
|
|
|
|
|
|
(define-command shell
|
|
|
|
|
"Run an inferior pseudo shell, with I/O through buffer *shell*.
|
|
|
|
|
With prefix argument, unconditionally create a new buffer.
|
|
|
|
|
If buffer exists, just switch to buffer *shell*.
|
|
|
|
|
|
|
|
|
|
The buffer is put in Pseudo Shell mode, giving commands for sending input
|
|
|
|
|
and tracking directories."
|
|
|
|
|
"P"
|
|
|
|
|
(lambda (new-buffer?)
|
|
|
|
|
(let ((buffer
|
|
|
|
|
(cond ((and (not new-buffer?)
|
|
|
|
|
(find-buffer "*shell*"))
|
|
|
|
|
=> (lambda (buffer)
|
|
|
|
|
(let ((end (buffer-end buffer)))
|
|
|
|
|
(if (or (mark= end (line-start end 0))
|
|
|
|
|
(not (mark= end
|
|
|
|
|
(pseudo-shell-line-start end))))
|
|
|
|
|
(begin
|
|
|
|
|
(buffer-freshline buffer)
|
|
|
|
|
(insert-pseudo-shell-prompt!
|
|
|
|
|
(buffer-end buffer)))))
|
|
|
|
|
buffer))
|
|
|
|
|
(else
|
|
|
|
|
(let ((buffer (create-buffer "*shell*")))
|
|
|
|
|
(insert-pseudo-shell-prompt! (buffer-start buffer))
|
|
|
|
|
(set-buffer-major-mode! buffer
|
|
|
|
|
(ref-mode-object pseudo-shell))
|
|
|
|
|
(set-buffer-default-directory!
|
|
|
|
|
buffer
|
|
|
|
|
(buffer-default-directory (current-buffer)))
|
|
|
|
|
buffer)))))
|
|
|
|
|
|
|
|
|
|
(set-buffer-point! buffer (buffer-end buffer))
|
|
|
|
|
(define-variable-local-value! buffer
|
|
|
|
|
(ref-variable-object pseudo-shell-active?)
|
|
|
|
|
true)
|
|
|
|
|
(select-buffer buffer))))
|
|
|
|
|
|
|
|
|
|
(define (insert-pseudo-shell-prompt! #!optional point)
|
|
|
|
|
;; This corresponds to the $p$g prompt pattern.
|
|
|
|
|
(insert-string (string-append
|
2021-04-26 07:57:47 -04:00
|
|
|
|
(pseudo-directory-namestring
|
2021-04-26 07:53:20 -04:00
|
|
|
|
(buffer-default-directory (current-buffer)))
|
|
|
|
|
">")
|
|
|
|
|
(if (default-object? point)
|
|
|
|
|
(current-point)
|
|
|
|
|
point)))
|
|
|
|
|
|
|
|
|
|
(define (pseudo-directory-namestring dir)
|
|
|
|
|
(string-upcase
|
|
|
|
|
(->namestring
|
|
|
|
|
(directory-pathname-as-file dir))))
|
|
|
|
|
|
|
|
|
|
(define-command pseudo-shell-bol
|
|
|
|
|
"Goes to the beginning of line, then skips past the prompt, if any.
|
|
|
|
|
With argument, don't skip the prompt -- go straight to column 0."
|
|
|
|
|
"P"
|
|
|
|
|
(lambda (argument)
|
|
|
|
|
(set-current-point!
|
|
|
|
|
(if argument
|
|
|
|
|
(line-start (current-point) 0)
|
|
|
|
|
(pseudo-shell-line-start (current-point))))))
|
|
|
|
|
|
|
|
|
|
(define (pseudo-shell-line-start mark)
|
|
|
|
|
(let ((start (line-start mark 0)))
|
|
|
|
|
(let ((mark (search-forward ">" start (line-end start 0))))
|
|
|
|
|
(if (and mark (mark<= mark (line-end start 0)))
|
|
|
|
|
mark
|
|
|
|
|
start))))
|
|
|
|
|
|
|
|
|
|
(define-command pseudo-shell-execute-command
|
|
|
|
|
"Execute the command on the current line."
|
|
|
|
|
()
|
|
|
|
|
(lambda ()
|
|
|
|
|
(let ((point (current-point))
|
|
|
|
|
(buffer (current-buffer)))
|
|
|
|
|
(let ((start (pseudo-shell-line-start point))
|
|
|
|
|
(end (line-end point 0)))
|
|
|
|
|
(let ((command (extract-string start end)))
|
|
|
|
|
(ring-push! (ref-variable comint-input-ring)
|
|
|
|
|
command)
|
|
|
|
|
(if (not (mark= end (buffer-end buffer)))
|
|
|
|
|
(begin
|
|
|
|
|
(buffer-freshline buffer)
|
|
|
|
|
(insert-region (line-start start 0) end
|
|
|
|
|
(buffer-end buffer))))
|
|
|
|
|
(buffer-freshline buffer)
|
|
|
|
|
(dynamic-wind
|
|
|
|
|
(lambda ()
|
|
|
|
|
unspecific)
|
|
|
|
|
(lambda ()
|
|
|
|
|
(pseudo-execute command
|
|
|
|
|
(buffer-default-directory buffer)
|
|
|
|
|
(buffer-end buffer))
|
|
|
|
|
(insert-newline (buffer-end buffer)))
|
|
|
|
|
(lambda ()
|
|
|
|
|
(if (ref-variable pseudo-shell-active? buffer)
|
|
|
|
|
(begin
|
|
|
|
|
(buffer-freshline buffer)
|
|
|
|
|
(insert-pseudo-shell-prompt! (buffer-end buffer))
|
|
|
|
|
(set-buffer-point! buffer (buffer-end buffer)))))))))))
|
|
|
|
|
|
|
|
|
|
(define (buffer-freshline buffer)
|
|
|
|
|
(let* ((end (buffer-end buffer))
|
|
|
|
|
(start (line-start end 0)))
|
|
|
|
|
(if (not (mark= start end))
|
|
|
|
|
(insert-newline end))))
|
|
|
|
|
|
|
|
|
|
(define (pseudo-execute command dir output-mark)
|
|
|
|
|
(let* ((command (string-trim command))
|
|
|
|
|
(next (string-find-next-char-in-set command char-set:whitespace))
|
|
|
|
|
(prog (if (not next)
|
|
|
|
|
command
|
|
|
|
|
(substring command 0 next))))
|
|
|
|
|
(let ((handler (assoc (string-downcase prog) pseudo-shell-builtins)))
|
|
|
|
|
(if (not handler)
|
|
|
|
|
(shell-command false output-mark dir command)
|
|
|
|
|
((cdr handler) prog
|
|
|
|
|
(if (not next)
|
|
|
|
|
""
|
|
|
|
|
(string-trim-left
|
|
|
|
|
(substring command (1+ next)
|
|
|
|
|
(string-length command))))
|
|
|
|
|
dir
|
|
|
|
|
output-mark)))))
|
|
|
|
|
|
|
|
|
|
(define-variable pseudo-shell-dirstack
|
|
|
|
|
"List of directories saved by pushd in this buffer's shell."
|
|
|
|
|
'())
|
|
|
|
|
|
|
|
|
|
(define-variable pseudo-shell-dirtrack? "" false)
|
|
|
|
|
|
|
|
|
|
(define (pseudo-parse-directory dir prog args)
|
|
|
|
|
(cond ((string-null? args)
|
|
|
|
|
false)
|
|
|
|
|
((string-find-next-char-in-set args char-set:whitespace)
|
|
|
|
|
(pseudo-error "Too many arguments" prog args))
|
|
|
|
|
(else
|
|
|
|
|
(let ((dir (merge-pathnames args dir)))
|
|
|
|
|
(if (not (file-directory? dir))
|
|
|
|
|
(pseudo-error "Not a directory" prog args))
|
|
|
|
|
(pathname-simplify (pathname-as-directory dir))))))
|
|
|
|
|
|
|
|
|
|
(define (pseudo-error string . strings)
|
|
|
|
|
(apply editor-error string
|
|
|
|
|
(map (lambda (string)
|
|
|
|
|
(string-append " " string))
|
|
|
|
|
strings)))
|
|
|
|
|
|
|
|
|
|
(define pseudo-shell-builtins
|
|
|
|
|
(let ((cd (lambda (prog args dir output-mark)
|
|
|
|
|
(if (not (ref-variable pseudo-shell-dirtrack?))
|
|
|
|
|
(editor-error "Not tracking directories"))
|
|
|
|
|
(let ((dir
|
|
|
|
|
(or (pseudo-parse-directory dir prog args)
|
|
|
|
|
(let ((home (get-environment-variable "HOME")))
|
|
|
|
|
(if (not home)
|
|
|
|
|
(pseudo-error "Unknown home:" prog)
|
|
|
|
|
(pathname-simplify
|
|
|
|
|
(pathname-as-directory
|
|
|
|
|
(merge-pathnames home dir))))))))
|
|
|
|
|
(set-default-directory dir)
|
|
|
|
|
(insert-string
|
|
|
|
|
(string-append (pseudo-directory-namestring dir)
|
|
|
|
|
"\n")
|
|
|
|
|
output-mark))))
|
|
|
|
|
|
|
|
|
|
(show-dirs
|
|
|
|
|
(lambda (dir output-mark)
|
|
|
|
|
(with-output-to-mark output-mark
|
|
|
|
|
(lambda ()
|
|
|
|
|
(write-char #\()
|
|
|
|
|
(write-string (pseudo-directory-namestring dir))
|
|
|
|
|
(let loop ((dirs (ref-variable pseudo-shell-dirstack)))
|
|
|
|
|
(if (null? dirs)
|
|
|
|
|
(begin
|
|
|
|
|
(write-char #\))
|
|
|
|
|
(write-char #\Newline))
|
|
|
|
|
(begin
|
|
|
|
|
(write-char #\Space)
|
|
|
|
|
(write-string (pseudo-directory-namestring (car dirs)))
|
|
|
|
|
(loop (cdr dirs))))))))))
|
|
|
|
|
|
|
|
|
|
`((""
|
|
|
|
|
. ,(lambda (prog args dir output-mark)
|
|
|
|
|
prog args dir output-mark ; ignored
|
|
|
|
|
(message "Empty command line")
|
|
|
|
|
(editor-beep)))
|
|
|
|
|
|
|
|
|
|
("cd" . ,cd)
|
|
|
|
|
|
|
|
|
|
("pushd"
|
|
|
|
|
. ,(lambda (prog args dir output-mark)
|
|
|
|
|
(if (not (ref-variable pseudo-shell-dirtrack?))
|
|
|
|
|
(editor-error "Not tracking directories"))
|
|
|
|
|
(let ((dir* (pseudo-parse-directory dir prog args))
|
|
|
|
|
(stack (ref-variable pseudo-shell-dirstack)))
|
|
|
|
|
(cond (dir*
|
|
|
|
|
(set-variable! pseudo-shell-dirstack (cons dir stack))
|
|
|
|
|
(set-default-directory dir*)
|
|
|
|
|
(show-dirs dir* output-mark))
|
|
|
|
|
((null? stack)
|
|
|
|
|
(pseudo-error "Empty directory stack:" prog))
|
|
|
|
|
(else
|
|
|
|
|
(let ((dir* (car stack)))
|
|
|
|
|
(set-variable! pseudo-shell-dirstack
|
|
|
|
|
(cons dir (cdr stack)))
|
|
|
|
|
(set-default-directory dir*)
|
|
|
|
|
(show-dirs dir* output-mark)))))))
|
|
|
|
|
|
|
|
|
|
("popd"
|
|
|
|
|
. ,(lambda (prog args dir output-mark)
|
|
|
|
|
dir ; ignored
|
|
|
|
|
(if (not (ref-variable pseudo-shell-dirtrack?))
|
|
|
|
|
(editor-error "Not tracking directories"))
|
|
|
|
|
(if (not (string-null? args))
|
|
|
|
|
(pseudo-error "Too many arguments:" prog)
|
|
|
|
|
(let ((stack (ref-variable pseudo-shell-dirstack)))
|
|
|
|
|
(if (null? stack)
|
|
|
|
|
(pseudo-error "Directory stack is empty:" prog)
|
|
|
|
|
(let ((dir (car stack)))
|
|
|
|
|
(set-variable! pseudo-shell-dirstack (cdr stack))
|
|
|
|
|
(set-default-directory dir)
|
|
|
|
|
(insert-string
|
|
|
|
|
(string-append (pseudo-directory-namestring dir)
|
|
|
|
|
"\n")
|
|
|
|
|
output-mark)))))))
|
|
|
|
|
|
|
|
|
|
("dirs"
|
|
|
|
|
. ,(lambda (prog args dir output-mark)
|
|
|
|
|
(if (not (ref-variable pseudo-shell-dirtrack?))
|
|
|
|
|
(editor-error "Not tracking directories"))
|
|
|
|
|
(if (not (string-null? args))
|
|
|
|
|
(pseudo-error "Too many arguments:" prog))
|
|
|
|
|
(show-dirs dir output-mark)))
|
|
|
|
|
|
|
|
|
|
("cwd" . ,cd)
|
|
|
|
|
|
|
|
|
|
("exit"
|
|
|
|
|
. ,(lambda (prog args dir output-mark)
|
|
|
|
|
prog args dir ; ignored
|
|
|
|
|
(define-variable-local-value! (mark-buffer output-mark)
|
|
|
|
|
(ref-variable-object pseudo-shell-active?)
|
|
|
|
|
false)
|
2021-04-26 07:57:47 -04:00
|
|
|
|
(message "Pseudo exitted"))))))
|