From: Chris Hanson Date: Sat, 26 Oct 1991 21:08:33 +0000 (+0000) Subject: M-x shell-command and M-x shell-command-on-region changed to make X-Git-Tag: 20090517-FFI~10118 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=49510fa2df06522834c4bdbf590f41f5f5af65e6;p=mit-scheme.git M-x shell-command and M-x shell-command-on-region changed to make process's working directory be the current buffer's default directory. Procedures SHELL-COMMAND and RUN-SYNCHRONOUS-SUBPROCESS changed to permit specification of this directory, and also to specify whether PTYs should be used. SHELL-COMMAND-ON-REGION eliminated because SHELL-COMMAND now takes an input-region argument. --- diff --git a/v7/src/edwin/dired.scm b/v7/src/edwin/dired.scm index 55cb84154..c1aa09e21 100644 --- a/v7/src/edwin/dired.scm +++ b/v7/src/edwin/dired.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/dired.scm,v 1.118 1991/10/22 12:27:55 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/dired.scm,v 1.119 1991/10/26 21:07:59 cph Exp $ ;;; ;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; @@ -213,27 +213,24 @@ CANNOT contain the 'F' option." (set-buffer-read-only! buffer)) (define (read-directory pathname switches mark) - (with-working-directory-pathname (pathname-directory-path pathname) - (lambda () - (if (file-directory? pathname) - (run-synchronous-process false - mark - (find-program "ls" false) - switches - (pathname->string pathname)) - (shell-command (string-append "ls " - switches - " " - (pathname-name-string pathname)) - mark))))) + (let ((directory (pathname-directory-path pathname))) + (if (file-directory? pathname) + (run-synchronous-process false mark directory false + (find-program "ls" false) + switches + (pathname->string pathname)) + (shell-command false mark directory false + (string-append "ls " + switches + " " + (pathname-name-string pathname)))))) (define (add-dired-entry pathname) (let ((lstart (line-start (current-point) 0)) (directory (pathname-directory-path pathname))) (if (pathname=? (buffer-default-directory (mark-buffer lstart)) directory) (let ((start (mark-right-inserting lstart))) - (run-synchronous-process false - lstart + (run-synchronous-process false lstart directory false (find-program "ls" directory) "-d" (ref-variable dired-listing-switches) @@ -385,12 +382,11 @@ CANNOT contain the 'F' option." (define (dired-change-line program argument) (let ((pathname (dired-current-pathname))) - (run-synchronous-process false - false - (find-program program - (pathname-directory-path pathname)) - argument - (pathname->string pathname)) + (let ((directory (pathname-directory-path pathname))) + (run-synchronous-process false false directory false + (find-program program directory) + argument + (pathname->string pathname))) (dired-redisplay pathname))) (define (dired-redisplay pathname) diff --git a/v7/src/edwin/manual.scm b/v7/src/edwin/manual.scm index ae2ac4d7a..b2c1f8d06 100644 --- a/v7/src/edwin/manual.scm +++ b/v7/src/edwin/manual.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/manual.scm,v 1.5 1991/10/22 10:48:44 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/manual.scm,v 1.6 1991/10/26 21:08:05 cph Exp $ ;;; ;;; Copyright (c) 1991 Massachusetts Institute of Technology ;;; @@ -89,17 +89,15 @@ where SECTION is the desired section of the manual, as in `tty(4)'." (if section (string-append section " ") "") topic "...") - (let ((manual-program - (if (file-exists? "/usr/bin/man") - "/usr/bin/man" - "/usr/ucb/man"))) - (if section - (shell-command - (string-append manual-program " " section " " topic) - (buffer-point buffer)) - (shell-command - (string-append manual-program " " topic) - (buffer-point buffer)))) + (shell-command false (buffer-point buffer) false false + (string-append (if (file-exists? "/usr/bin/man") + "/usr/bin/man" + "/usr/ucb/man") + (if section + (string-append " " section) + "") + " " + topic)) (message "Cleaning manual entry for " topic "...") (nuke-nroff-bs buffer) (buffer-not-modified! buffer) diff --git a/v7/src/edwin/print.scm b/v7/src/edwin/print.scm index 0ad05af91..3a4b8149d 100644 --- a/v7/src/edwin/print.scm +++ b/v7/src/edwin/print.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/print.scm,v 1.2 1991/09/20 20:56:08 arthur Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/print.scm,v 1.3 1991/10/26 21:08:10 cph Exp $ ;;; ;;; Copyright (c) 1991 Massachusetts Institute of Technology ;;; @@ -110,9 +110,8 @@ Variable LPR-SWITCHES is a list of extra switches (strings) to pass to lpr." (local-set-variable! tab-width width))) (untabify-region (region-start region) (region-end region)))) (shell-command-region + region (buffer-end buffer) false false (string-append (ref-variable lpr-command (current-buffer)) " " - (switches->string switches)) - (buffer-end buffer) - region) + (switches->string switches))) (message "Spooling...done")))) \ No newline at end of file diff --git a/v7/src/edwin/process.scm b/v7/src/edwin/process.scm index f8b636f7d..d88ca20e8 100644 --- a/v7/src/edwin/process.scm +++ b/v7/src/edwin/process.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/process.scm,v 1.10 1991/10/11 03:58:56 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/process.scm,v 1.11 1991/10/26 21:08:14 cph Exp $ ;;; ;;; Copyright (c) 1991 Massachusetts Institute of Technology ;;; @@ -140,43 +140,46 @@ False means don't delete them until \\[list-processes] is run." (mark-right-inserting-copy (buffer-end buffer)))))) (define (start-process name buffer environment program . arguments) - (let ((directory (buffer-default-directory buffer))) - (let ((make-subprocess - (let ((filename (find-program program directory)) - (arguments (list->vector (cons program arguments)))) - (if (and (eq? true (ref-variable process-connection-type)) - ((ucode-primitive have-ptys? 0))) - (lambda () - (start-pty-subprocess filename arguments environment)) - (lambda () - (start-pipe-subprocess filename arguments environment)))))) - ;; Calling WITH-WORKING-DIRECTORY-PATHNAME is a kludge -- - ;; there's no other way to specify the working directory of the - ;; subprocess. The subprocess abstraction should be fixed to - ;; allow this. - (with-working-directory-pathname directory - (lambda () - (without-interrupts - (lambda () - (let ((subprocess (make-subprocess))) - (let ((channel (subprocess-input-channel subprocess))) - (if channel - (begin - (channel-nonblocking channel) - (channel-register channel)))) - (let ((process - (%make-process - subprocess - (do ((n 2 (+ n 1)) - (name* name - (string-append name - "<" (number->string n) ">"))) - ((not (get-process-by-name name*)) name*)) - buffer))) - (update-process-mark! process) - (subprocess-put! subprocess 'EDWIN-PROCESS process) - (set! edwin-processes (cons process edwin-processes)) - process))))))))) + (let ((make-subprocess + (let ((filename + (find-program program (buffer-default-directory buffer))) + (arguments (list->vector (cons program arguments)))) + (if (and (eq? true (ref-variable process-connection-type)) + ((ucode-primitive have-ptys? 0))) + (lambda () + (start-pty-subprocess filename arguments environment)) + (lambda () + (start-pipe-subprocess filename arguments environment)))))) + (with-process-directory buffer + (lambda () + (without-interrupts + (lambda () + (let ((subprocess (make-subprocess))) + (let ((channel (subprocess-input-channel subprocess))) + (if channel + (begin + (channel-nonblocking channel) + (channel-register channel)))) + (let ((process + (%make-process + subprocess + (do ((n 2 (+ n 1)) + (name* name + (string-append name + "<" (number->string n) ">"))) + ((not (get-process-by-name name*)) name*)) + buffer))) + (update-process-mark! process) + (subprocess-put! subprocess 'EDWIN-PROCESS process) + (set! edwin-processes (cons process edwin-processes)) + process)))))))) + +(define (with-process-directory buffer thunk) + ;; Calling WITH-WORKING-DIRECTORY-PATHNAME is a kludge -- there's + ;; no other way to specify the working directory of the subprocess. + ;; The subprocess abstraction should be fixed to allow this. + (with-working-directory-pathname (buffer-default-directory buffer) + thunk)) (define (delete-process process) (let ((subprocess (process-subprocess process))) @@ -455,23 +458,25 @@ after the listing is made.)" ;;;; Synchronous Subprocesses -(define (shell-command command output-mark) - (run-synchronous-process false output-mark "/bin/sh" "-c" command)) - -(define (shell-command-region command output-mark input-region) - (run-synchronous-process input-region output-mark "/bin/sh" "-c" command)) - -(define (run-synchronous-process input-region output-mark program . arguments) - (let ((process false)) +(define (run-synchronous-process input-region output-mark directory pty? + program . arguments) + (let ((process false) + (start-process + (lambda () + ((if (and pty? ((ucode-primitive have-ptys? 0))) + start-pty-subprocess + start-pipe-subprocess) + program + (list->vector + (cons (os/filename-non-directory program) arguments)) + false)))) (dynamic-wind (lambda () (if (not process) (set! process - (start-pipe-subprocess - program - (list->vector - (cons (os/filename-non-directory program) arguments)) - false))) + (if directory + (with-working-directory-pathname directory start-process) + (start-process)))) unspecific) (lambda () (call-with-output-copier process output-mark @@ -588,17 +593,18 @@ Optional second arg true (prefix arg, if interactive) means insert output in current buffer after point (leave mark after it)." "sShell command\nP" (lambda (command insert-at-point?) - (if insert-at-point? - (begin - (if (buffer-read-only? (current-buffer)) - (barf-if-read-only)) - (let ((point (current-point))) - (push-current-mark! point) - (shell-command command point)) - ((ref-command exchange-point-and-mark))) - (shell-command-pop-up-output - (lambda (output-mark) - (shell-command command output-mark)))))) + (let ((directory (buffer-default-directory (current-buffer)))) + (if insert-at-point? + (begin + (if (buffer-read-only? (current-buffer)) + (barf-if-read-only)) + (let ((point (current-point))) + (push-current-mark! point) + (shell-command false point directory false command)) + ((ref-command exchange-point-and-mark))) + (shell-command-pop-up-output + (lambda (output-mark) + (shell-command false output-mark directory false command))))))) (define-command shell-command-on-region "Execute string COMMAND in inferior shell with region as input. @@ -606,32 +612,35 @@ Normally display output (if any) in temp buffer; Prefix arg means replace the region with it." "r\nsShell command on region\nP" (lambda (region command replace-region?) - (if replace-region? - (let ((point (current-point)) - (mark (current-mark))) - (let ((swap? (mark< point mark)) - (temp)) - (dynamic-wind - (lambda () unspecific) - (lambda () - (set! temp (temporary-buffer " *shell-output*")) - (shell-command-region command - (buffer-start temp) - (make-region point mark)) - (without-interrupts - (lambda () - (delete-string point mark) - (insert-region (buffer-start temp) - (buffer-end temp) - (current-point))))) - (lambda () - (kill-buffer temp) - (set! temp) - unspecific)) - (if swap? ((ref-command exchange-point-and-mark))))) - (shell-command-pop-up-output - (lambda (output-mark) - (shell-command-region command output-mark region)))))) + (let ((directory (buffer-default-directory (current-buffer)))) + (if replace-region? + (let ((point (current-point)) + (mark (current-mark))) + (let ((swap? (mark< point mark)) + (temp)) + (dynamic-wind + (lambda () unspecific) + (lambda () + (set! temp (temporary-buffer " *shell-output*")) + (shell-command (make-region point mark) + (buffer-start temp) + directory + false + command) + (without-interrupts + (lambda () + (delete-string point mark) + (insert-region (buffer-start temp) + (buffer-end temp) + (current-point))))) + (lambda () + (kill-buffer temp) + (set! temp) + unspecific)) + (if swap? ((ref-command exchange-point-and-mark))))) + (shell-command-pop-up-output + (lambda (output-mark) + (shell-command region output-mark directory false command))))))) (define (shell-command-pop-up-output generate-output) (let ((buffer (temporary-buffer "*Shell Command Output*"))) @@ -641,6 +650,10 @@ Prefix arg means replace the region with it." (if (mark< start (buffer-end buffer)) (pop-up-buffer buffer false) (message "(Shell command completed with no output)"))))) + +(define (shell-command input-region output-mark directory pty? command) + (run-synchronous-process input-region output-mark directory pty? + "/bin/sh" "-c" command)) ;;; These procedures are not specific to the process abstraction. diff --git a/v7/src/edwin/rmail.scm b/v7/src/edwin/rmail.scm index 3b6b3524a..e1c2c103e 100644 --- a/v7/src/edwin/rmail.scm +++ b/v7/src/edwin/rmail.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/rmail.scm,v 1.9 1991/10/10 22:54:44 arthur Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/rmail.scm,v 1.10 1991/10/26 21:08:26 cph Exp $ ;;; ;;; Copyright (c) 1991 Massachusetts Institute of Technology ;;; @@ -495,8 +495,7 @@ and use that file as the inbox." (let ((error-buffer (temporary-buffer " movemail errors"))) (let ((start (buffer-start error-buffer)) (end (buffer-end error-buffer))) - (run-synchronous-process false - start + (run-synchronous-process false start false false (pathname->string (edwin-etc-pathname "movemail")) (pathname->string source) diff --git a/v7/src/edwin/sendmail.scm b/v7/src/edwin/sendmail.scm index 64f359ff8..2ab3d465b 100644 --- a/v7/src/edwin/sendmail.scm +++ b/v7/src/edwin/sendmail.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/sendmail.scm,v 1.10 1991/08/28 15:55:18 bal Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/sendmail.scm,v 1.11 1991/10/26 21:08:33 cph Exp $ ;;; ;;; Copyright (c) 1991 Massachusetts Institute of Technology ;;; @@ -471,6 +471,8 @@ Numeric argument means justify as well." (apply run-synchronous-process (make-region start end) (and error-buffer (buffer-end error-buffer)) + false + false (ref-variable sendmail-program) "-oi" "-t" ;; Always specify who from, since some systems have