;;;; -*- 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.
(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
(error :output)
(if-error-exists :error)
status-hook
- (external-format :default))
+ (external-format :default)
+ (directory nil directory-p))
#+sb-doc
#.(concatenate
'string
(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
(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
(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))
(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)))
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;
}
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;
}
}
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);
}
close(channel[1]);
}
- _exit(1);
+ _exit(failure_code);
}
#else /* !LISP_FEATURE_WIN32 */
int search,
char *envp,
char *ptyname,
- int wait
+ int wait,
+ char *pwd
)
{
int stdout_backup, stdin_backup, stderr_backup, wait_mode;
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 );
(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))))))
projects / sbcl.git / commitdiff