Stelian,
> I added to iolib.os a different
> implementation that calls posix_spawn(3)
Great, I agree that posix_spawn is a better solution than fork/exec.
> The implementation is currently not very complete
I rewrite your code, so that it now passes my tests.
I tested it on Linux with SBCL, Clozure CL and CLISP.
My code in fork iolib:
http://gitorious.org/~archimag/iolib/archimag-iolib/blobs/master/src/os/create-process-unix.lisp
My tests: http://gitorious.org/iolib-test/iolib-test/blobs/master/process.lisp
Andrey
diff --git a/src/os/create-process-unix.lisp b/src/os/create-process-unix.lisp
index 4a3f5ef..442be26 100644
--- a/src/os/create-process-unix.lisp
+++ b/src/os/create-process-unix.lisp
@@ -9,26 +9,50 @@
((pid :initarg :pid :reader process-pid)
(stdin :initform nil :reader process-stdin)
(stdout :initform nil :reader process-stdout)
- (stderr :initform nil :reader process-stderr)))
+ (stderr :initform nil :reader process-stderr)
+ (terminated-p :initform nil )))
(defmethod initialize-instance :after ((process process) &key stdin stdout stderr)
(with-slots ((in stdin) (out stdout) (err stderr))
process
- (setf in (make-instance 'iolib.streams:dual-channel-gray-stream
- :output-fd stdin)
- out (make-instance 'iolib.streams:dual-channel-gray-stream
- :input-fd stdout)
- err (make-instance 'iolib.streams:dual-channel-gray-stream
- :input-fd stderr))))
+ (setf in (if stdin
+ (make-instance 'iolib.streams:dual-channel-gray-stream
+ :output-fd stdin))
+ out (if stdout
+ (make-instance 'iolib.streams:dual-channel-gray-stream
+ :input-fd stdout))
+ err (if stderr
+ (make-instance 'iolib.streams:dual-channel-gray-stream
+ :input-fd stderr)))))
+
+(defun process-wait (process)
+ (setf (slot-value process 'terminated-p)
+ (isys:waitpid (process-pid process) 0)))
+
+(defun process-kill (process signum)
+ (isys:kill (process-pid process) signum))
+
+(defun close-process-stream (stream &key abort)
+ (when stream
+ (close stream :abort abort)
+ (isys:close (or (iolib.streams:output-fd-of stream)
+ (iolib.streams:input-fd-of stream)))))
(defmethod close ((process process) &key abort)
(with-slots (pid stdin stdout stderr)
process
- (close stdin :abort abort)
- (close stdout :abort abort)
- (close stderr :abort abort)
+ (close-process-stream stdin :abort abort)
+ (close-process-stream stdout :abort abort)
+ (close-process-stream stderr :abort abort)
+ #-clisp (unless (slot-value process 'terminated-p)
+ (isys:waitpid pid 0))
(setf pid nil stdin nil stdout nil stderr nil)))
+(defun process-stdin-close (process)
+ (close-process-stream (process-stdin process))
+ (setf (slot-value process 'stdin)
+ nil))
+
(defmethod print-object ((o process) s)
(print-unreadable-object (o s :type t :identity t)
(format s ":pid ~S" (process-pid o))))
@@ -74,55 +98,92 @@
,@body)
(deallocate-null-ended-list ,argv))))))
-(defmacro with-3-pipes ((stdin-r stdin-w stdout-r stdout-w stderr-r stderr-w)
- &body body)
- `(multiple-value-bind (,stdin-r ,stdin-w) (isys:pipe)
- (multiple-value-bind (,stdout-r ,stdout-w) (isys:pipe)
- (multiple-value-bind (,stderr-r ,stderr-w) (isys:pipe)
- (unwind-protect-case ()
- (progn ,@body)
- ;; These are the FDs that we would use on the Lisp side
- (:abort
- (isys:close ,stdin-w)
- (isys:close ,stdout-r)
- (isys:close ,stderr-r))
- ;; These FDs are shared with the subprocess, must be closed always
- (:always
- (isys:close ,stdin-r)
- (isys:close ,stdout-w)
- (isys:close ,stderr-w)))))))
-
-(defun create-process (program &optional arguments &key (search t) environment
- ;; path uid gid effective
- )
- (with-posix-spawn-arguments (attributes file-actions pid)
- (with-argv (argv program arguments)
- (with-c-environment (environment)
- (with-3-pipes (stdin-r stdin-w stdout-r stdout-w stderr-r stderr-w)
- (posix-spawn-file-actions-adddup2 file-actions stdin-r +stdin+)
- (posix-spawn-file-actions-adddup2 file-actions stdout-w +stdout+)
- (posix-spawn-file-actions-adddup2 file-actions stderr-w +stderr+)
- (with-foreign-string (cfile program)
- (if search
- (posix-spawnp pid cfile file-actions attributes argv isys:*environ*)
- (posix-spawn pid cfile file-actions attributes argv isys:*environ*)))
- (make-instance 'process :pid (mem-ref pid 'pid-t)
- :stdin stdin-w :stdout stdout-r :stderr stderr-r))))))
-
-(defun run-program (program &optional arguments &key (search t) environment)
+
+(defun create-process (program arguments &key stdin stdout stderr union-stdout-stderr environment search)
+ (flet ((create-pipe (flag)
+ (if flag
+ (multiple-value-bind (rd wr) (isys:pipe)
+ (cons rd wr))))
+ (pipe-rd (pipe) (car pipe))
+ (pipe-wr (pipe) (cdr pipe))
+ (close-fd (fd)
+ (when fd
+ (isys:close fd))))
+ (let ((p-stdin (create-pipe stdin))
+ (p-stdout (create-pipe (or stdout
+ union-stdout-stderr)))
+ (p-stderr (create-pipe (if (not union-stdout-stderr)
+ stderr))))
+ (unwind-protect-case ()
+ (with-posix-spawn-arguments (attributes file-actions pid)
+ (with-argv (argv program arguments)
+ (with-c-environment (environment)
+ (when stdin
+ (posix-spawn-file-actions-addclose file-actions (pipe-wr p-stdin))
+ (posix-spawn-file-actions-adddup2 file-actions (pipe-rd p-stdin) +stdin+)
+ (posix-spawn-file-actions-addclose file-actions (pipe-rd p-stdin)))
+ (cond
+ (union-stdout-stderr
+ (posix-spawn-file-actions-addclose file-actions (pipe-rd p-stdout))
+ (posix-spawn-file-actions-adddup2 file-actions (pipe-wr p-stdout) +stdout+)
+ (posix-spawn-file-actions-adddup2 file-actions (pipe-wr p-stdout) +stderr+)
+ (posix-spawn-file-actions-addclose file-actions (pipe-wr p-stdout)))
+ (t (when stdout
+ (posix-spawn-file-actions-addclose file-actions (pipe-rd p-stdout))
+ (posix-spawn-file-actions-adddup2 file-actions (pipe-wr p-stdout) +stdout+)
+ (posix-spawn-file-actions-addclose file-actions (pipe-wr p-stdout)))
+ (when stderr
+ (posix-spawn-file-actions-addclose file-actions (pipe-rd p-stderr))
+ (posix-spawn-file-actions-adddup2 file-actions (pipe-wr p-stderr) +stderr+)
+ (posix-spawn-file-actions-addclose file-actions (pipe-wr p-stderr)))))
+ (with-foreign-string (cfile program)
+ (if search
+ (posix-spawnp pid cfile file-actions attributes argv isys:*environ*)
+ (posix-spawn pid cfile file-actions attributes argv isys:*environ*)))
+ (make-instance 'process
+ :pid (mem-ref pid 'pid-t)
+ :stdin (pipe-wr p-stdin)
+ :stdout (pipe-rd p-stdout)
+ :stderr (pipe-rd p-stderr)))))
+ ;; These are the FDs that we would use on the Lisp side
+ (:abort
+ (close-fd (pipe-wr p-stdin))
+ (close-fd (pipe-rd p-stdout))
+ (close-fd (pipe-rd p-stderr)))
+ ;; These FDs are shared with the subprocess, must be closed always
+ (:always
+ (close-fd (pipe-rd p-stdin))
+ (close-fd (pipe-wr p-stdout))
+ (close-fd (pipe-wr p-stderr)))))))
+
+(defun create-process-sh (cmd &key stdin stdout stderr union-stdout-stderr environment)
+ (create-process "/bin/sh"
+ (list "-c" cmd)
+ :stdin stdin
+ :stdout stdout
+ :stderr stderr
+ :union-stdout-stderr union-stdout-stderr
+ :environment environment
+ :search nil))
+
+(defmacro with-child-process ((process cmd &key stdin stdout stderr union-stdout-stderr environment) &body body)
+ `(let ((,process (create-process-sh ,cmd
+ :stdin ,stdin
+ :stdout ,stdout
+ :stderr ,stderr
+ :union-stdout-stderr ,union-stdout-stderr
+ :environment ,environment)))
+ (unwind-protect
+ (progn ,@body)
+ (close ,process))))
+
+(defun popen (cmd &key environment)
(flet ((slurp-stream-into-string (stream)
(with-output-to-string (s)
(loop :for c := (read-char stream nil nil)
- :while c :do (write-char c s)))))
- (let ((process (create-process program arguments
- :search search
- :environment environment)))
- (values (process-wait process)
- (slurp-stream-into-string (process-stdout process))
- (slurp-stream-into-string (process-stderr process))))))
+ :while c :do (write-char c s)))))
+ (with-child-process (proc cmd :stdout t :stderr t :environment environment)
+ (values (slurp-stream-into-string (process-stdout proc))
+ (slurp-stream-into-string (process-stderr proc))))))
-(defun process-wait (process)
- (isys:waitpid (process-pid process) 0))
-(defun process-kill (process signum)
- (isys:kill (process-pid process) signum))
diff --git a/src/os/pkgdcl.lisp b/src/os/pkgdcl.lisp
index 65b36b5..046ff31 100644
--- a/src/os/pkgdcl.lisp
+++ b/src/os/pkgdcl.lisp
@@ -22,10 +22,12 @@
#:process
#:process-pid
#:process-stdin
+ #:process-stdin-close
#:process-stdout
#:process-stderr
#:create-process
- #:run-program
+ #:with-child-process
+ #:popen
#:process-wait
#:process-kill
_______________________________________________
IOLib-devel mailing list
[email protected]
http://common-lisp.net/cgi-bin/mailman/listinfo/iolib-devel
