File 0002-Add-directory-argument-to-sb-ext-run-progr... of Package sbcl

Overview Repositories Revisions Requests Users Attributes Meta

File 0002-Add-directory-argument-to-sb-ext-run-program.patch of Package sbcl (Revision f3aa57a9614eb24475e08b4725ad0e2b)

Currently displaying revision f3aa57a9614eb24475e08b4725ad0e2b , Show latest

From 606dfed39b56dc435ff40e7baf47a455019aae49 Mon Sep 17 00:00:00 2001
From: Stas Boukarev <stassats@gmail.com>
Date: Mon, 29 Apr 2013 23:28:32 +0400
Subject: [PATCH 2/8] Add :directory argument to sb-ext:run-program.

The implementation uses chdir(2) on Unices, the lpCurrentDirectory
argument to CreateProcessW on Windows.
Slightly adapted from the patch by Matthias Benkard.
Closes lp#791800
---
 NEWS                          |  3 +++
 src/code/run-program.lisp     | 46 +++++++++++++++++++++++++-----------------
 src/code/warm-mswin.lisp      |  4 ++--
 src/runtime/run-program.c     | 47 +++++++++++++++++++++++++++++--------------
 tests/run-program.impure.lisp | 16 +++++++++++++++
 5 files changed, 81 insertions(+), 35 deletions(-)

diff --git a/NEWS b/NEWS
index b773b9b..4b3f503 100644
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,8 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
 changes relative to sbcl-1.1.7:
+  * enhancement: RUN-PROGRAM supports a :DIRECTORY argument to set
+    the working directory of the spawned process.
+    (lp#791800) (patch by Matthias Benkard)
   * bug fix: handle errors when initializing *default-pathname-defaults*,
     sb-ext:*runtime-pathname*, sb-ext:*posix-argv* on startup, like character
     decoding errors, or directories being deleted.
diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp
index bec0abe..7c180ea 100644
--- a/src/code/run-program.lisp
+++ b/src/code/run-program.lisp
@@ -555,7 +555,8 @@ status slot."
   (search sb-alien:int)
   (envp (* sb-alien:c-string))
   (pty-name sb-alien:c-string)
-  (wait sb-alien:int))
+  (wait sb-alien:int)
+  (pwd sb-alien:c-string))
 
 ;;; FIXME: There shouldn't be two semiredundant versions of the
 ;;; documentation. Since this is a public extension function, the
@@ -617,7 +618,8 @@ status slot."
                     (error :output)
                     (if-error-exists :error)
                     status-hook
-                    (external-format :default))
+                    (external-format :default)
+                    (directory nil directory-p))
   #+sb-doc
   #.(concatenate
      'string
@@ -809,23 +811,26 @@ Users Manual for details about the PROCESS structure."#-win32"
                              (with-args-vec (args-vec simple-args)
                                (with-no-with (#+win32 (environment-vec))
                                  (with-environment-vec (environment-vec)
-                                   (setq child
-                                         #+win32
-                                         (sb-win32::mswin-spawn
-                                          progname
-                                          (with-output-to-string (argv)
-                                            (dolist (arg simple-args)
-                                              (write-string arg argv)
-                                              (write-char #\Space argv)))
-                                          stdin stdout stderr
-                                          search nil wait)
-                                         #-win32
-                                         (without-gcing
+                                   (let ((pwd-string
+                                           (and directory-p (native-namestring directory))))
+                                     (setq child
+                                           #+win32
+                                           (sb-win32::mswin-spawn
+                                            progname
+                                            (with-output-to-string (argv)
+                                              (dolist (arg simple-args)
+                                                (write-string arg argv)
+                                                (write-char #\Space argv)))
+                                            stdin stdout stderr
+                                            search nil wait pwd-string)
+                                           #-win32
+                                           (without-gcing
                                              (spawn progname args-vec
                                                     stdin stdout stderr
                                                     (if search 1 0)
                                                     environment-vec pty-name
-                                                    (if wait 1 0))))
+                                                    (if wait 1 0)
+                                                    pwd-string))))
                                    (unless (minusp child)
                                      (setf proc
                                            (apply
@@ -846,10 +851,15 @@ Users Manual for details about the PROCESS structure."#-win32"
                                      (push proc *active-processes*)))))))
                          ;; Report the error outside the lock.
                          (case child
-                           (-2
-                            (error "Couldn't execute ~S: ~A" progname (strerror)))
                            (-1
-                            (error "Couldn't fork child process: ~A" (strerror)))))))))))
+                            (error "Couldn't fork child process: ~A"
+                                   (strerror)))
+                           (-2
+                            (error "Couldn't execute ~S: ~A"
+                                   progname (strerror)))
+                           (-3
+                            (error "Couldn't change directory to ~S: ~A"
+                                   directory (strerror)))))))))))
         (dolist (fd *close-in-parent*)
           (sb-unix:unix-close fd))
         (unless proc
diff --git a/src/code/warm-mswin.lisp b/src/code/warm-mswin.lisp
index 5a973ff..9bf586b 100644
--- a/src/code/warm-mswin.lisp
+++ b/src/code/warm-mswin.lisp
@@ -67,7 +67,7 @@
 (define-alien-routine ("GetExitCodeThread" get-exit-code-thread) int
   (handle handle) (exit-code dword :out))
 
-(defun mswin-spawn (program argv stdin stdout stderr searchp envp waitp)
+(defun mswin-spawn (program argv stdin stdout stderr searchp envp waitp pwd)
   (declare (ignorable envp))
   (let ((std-handles (multiple-value-list (get-std-handles)))
         (inheritp nil))
@@ -93,7 +93,7 @@
           (if (create-process (if searchp nil program)
                               argv
                               nil nil
-                              inheritp 0 nil nil
+                              inheritp 0 nil pwd
                               (alien-sap startup-info)
                               (alien-sap process-information))
               (let ((child (slot process-information 'process-handle)))
diff --git a/src/runtime/run-program.c b/src/runtime/run-program.c
index ef9c51c..57df79a 100644
--- a/src/runtime/run-program.c
+++ b/src/runtime/run-program.c
@@ -100,12 +100,13 @@ set_pty(char *pty_name)
 
 extern char **environ;
 int spawn(char *program, char *argv[], int sin, int sout, int serr,
-          int search, char *envp[], char *pty_name, int wait)
+          int search, char *envp[], char *pty_name, int wait, char *pwd)
 {
     pid_t pid;
     int fd;
     int channel[2];
     sigset_t sset;
+    int failure_code = 2;
 
     channel[0] = -1;
     channel[1] = -1;
@@ -140,10 +141,14 @@ int spawn(char *program, char *argv[], int sin, int sout, int serr,
             }
             close(channel[0]);
             if (child_errno) {
-                waitpid(pid, NULL, 0);
-                /* Our convention to tell Lisp that it was the exec that
-                 * failed, not the fork. */
-                pid = -2;
+                int status;
+                waitpid(pid, &status, 0);
+                /* Our convention to tell Lisp that it was the exec or
+                   chdir that failed, not the fork. */
+                /* FIXME: there are other values waitpid(2) can return. */
+                if (WIFEXITED(status)) {
+                  pid = -WEXITSTATUS(status);
+                }
                 errno = child_errno;
             }
         }
@@ -193,16 +198,20 @@ int spawn(char *program, char *argv[], int sin, int sout, int serr,
         if (fd != channel[1]) close(fd);
 #endif
 
-    if (envp) {
-      environ = envp;
+    if (pwd && chdir(pwd) < 0) {
+       failure_code = 3;
+    } else {
+        if (envp) {
+            environ = envp;
+        }
+        /* Exec the program. */
+        if (search)
+            execvp(program, argv);
+        else
+            execv(program, argv);
     }
-    /* Exec the program. */
-    if (search)
-      execvp(program, argv);
-    else
-      execv(program, argv);
 
-    /* When exec fails and channel is available, send the errno value. */
+    /* When exec or chdir fails and channel is available, send the errno value. */
     if (-1 != channel[1]) {
         int our_errno = errno;
         int bytes = sizeof(int);
@@ -223,7 +232,7 @@ int spawn(char *program, char *argv[], int sin, int sout, int serr,
         }
         close(channel[1]);
     }
-    _exit(1);
+    _exit(failure_code);
 }
 #else  /* !LISP_FEATURE_WIN32 */
 
@@ -254,7 +263,8 @@ HANDLE spawn (
     int search,
     char *envp,
     char *ptyname,
-    int wait
+    int wait,
+    char *pwd
     )
 {
     int stdout_backup, stdin_backup, stderr_backup, wait_mode;
@@ -291,6 +301,13 @@ HANDLE spawn (
         wait_mode = P_WAIT;
     }
 
+    /* Change working directory if supplied. */
+    if (pwd) {
+        if (chdir(pwd) < 0) {
+            goto error_exit;
+        }
+    }
+
     /* Spawn process given on the command line*/
     if (search)
         hProcess = (HANDLE) spawnvp ( wait_mode, program, (char* const* )argv );
diff --git a/tests/run-program.impure.lisp b/tests/run-program.impure.lisp
index 6b6673a..0088c56 100644
--- a/tests/run-program.impure.lisp
+++ b/tests/run-program.impure.lisp
@@ -322,3 +322,19 @@
     (assert (null (sb-ext:run-program "/bin/cat" '() :output #.(or *compile-file-truename*
                                                                    *load-truename*)
                                       :if-output-exists nil)))))
+
+
+(with-test (:name (:run-program :set-directory))
+  (let* ((directory #-win32 "/"
+                    #+win32 "c:\\")
+         (out (sb-ext:process-output
+               (sb-ext:run-program #-win32 "/bin/sh"
+                                   #-win32 '("-c" "pwd")
+                                   #+win32 "cmd.exe"
+                                   #+win32 '("/c" "cd")
+                                   :output :stream
+                                   :directory directory
+                                   :search t))))
+    (assert
+     (equal directory
+            (string-right-trim '(#\Return) (read-line out))))))
-- 
1.8.2.1

Places

File 0002-Add-directory-argument-to-sb-ext-run-program.patch of Package sbcl (Revision f3aa57a9614eb24475e08b4725ad0e2b)

Places