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 55cb841540fe41b8222390aacc6d63d8a2ffe242..c1aa09e219cb9457456f3ed0a172fe1923e28eb8 100644 (file)
--- 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 ae2ac4d7aa731458a6f6a772a0f4751d4ea05f78..b2c1f8d06c698dae6130bb390b7041301a3b7815 100644 (file)
--- 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 0ad05af91272a2d460f13dbae05464d56ac94bbe..3a4b8149d370fe17dea3fcde96f7684bf1e0f570 100644 (file)
--- 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 f8b636f7d9d941995a92757160de510b79e379c0..d88ca20e8dfc217a264ea969fb73e7c8e004a1d9 100644 (file)
--- 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))))))
 \f
 (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.)"
 \f
 ;;;; 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))
 \f
 ;;; These procedures are not specific to the process abstraction.
 

diff --git a/v7/src/edwin/rmail.scm b/v7/src/edwin/rmail.scm
index 3b6b3524a7783ed0a3061dae15a970d2b172b7c8..e1c2c103e84aa38eb749010ad7ee585718cf396c 100644 (file)
--- 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 64f359ff8beafa317ea8fc87fb4fb61411374040..2ab3d465b254957c68822275611b60d2c51fe541 100644 (file)
--- 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