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)))))