Date: Monday, September 20, 2010 @ 09:50:53 Author: rtoy Path: /project/cmucl/cvsroot/src/code
Modified: run-program.lisp
Add support for external formats for RUN-PROGRAM, which now takes an :EXTERNAL-FORMAT keyword argument to specify the format to use for any streams that RUN-PROGRAM needs to create.
Patch from Paul Foley.
------------------+ run-program.lisp | 36 ++++++++++++++++++++++++------------ 1 file changed, 24 insertions(+), 12 deletions(-)
Index: src/code/run-program.lisp diff -u src/code/run-program.lisp:1.31 src/code/run-program.lisp:1.32 --- src/code/run-program.lisp:1.31 Tue Apr 20 13:57:45 2010 +++ src/code/run-program.lisp Mon Sep 20 09:50:52 2010 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/code/run-program.lisp,v 1.31 2010-04-20 17:57:45 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/code/run-program.lisp,v 1.32 2010-09-20 13:50:52 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -325,7 +325,7 @@
;;; OPEN-PTY -- internal ;;; -(defun open-pty (pty cookie) +(defun open-pty (pty cookie &optional (external-format :default)) (when pty (multiple-value-bind (master slave name) @@ -340,7 +340,8 @@ (push new-fd *close-on-error*) (copy-descriptor-to-stream new-fd pty cookie))) (values name - (system:make-fd-stream master :input t :output t))))) + (system:make-fd-stream master :input t :output t + :external-format external-format)))))
(defmacro round-bytes-to-words (n) @@ -454,7 +455,8 @@ (defun run-program (program args &key (env *environment-list*) (wait t) pty input if-input-does-not-exist output (if-output-exists :error) - (error :output) (if-error-exists :error) status-hook) + (error :output) (if-error-exists :error) status-hook + (external-format :default)) "RUN-PROGRAM creates a new process and runs the unix program in the file specified by the simple-string PROGRAM. ARGS are the standard arguments that can be passed to a Unix program, for no arguments @@ -506,14 +508,16 @@ same place as normal output. :status-hook - This is a function the system calls whenever the status of the - process changes. The function takes the process as an argument." + process changes. The function takes the process as an argument. + :external-format - + This is the external-format used for communication with the subprocess."
;; Make sure the interrupt handler is installed. (system:enable-interrupt unix:sigchld #'sigchld-handler) ;; Make sure all the args are okay. (unless (every #'simple-string-p args) (error (intl:gettext "All args to program must be simple strings -- ~S.") args)) - ;; Pre-pend the program to the argument list. + ;; Prepend the program to the argument list. (push (namestring program) args) ;; Clear random specials used by GET-DESCRIPTOR-FOR to communicate cleanup ;; info. Also, establish proc at this level so we can return it. @@ -526,21 +530,24 @@ (multiple-value-bind (stdin input-stream) (get-descriptor-for input cookie :direction :input - :if-does-not-exist if-input-does-not-exist) + :if-does-not-exist if-input-does-not-exist + :external-format external-format) (multiple-value-bind (stdout output-stream) (get-descriptor-for output cookie :direction :output :if-does-not-exist :create - :if-exists if-output-exists) + :if-exists if-output-exists + :external-format external-format) (multiple-value-bind (stderr error-stream) (if (eq error :output) (values stdout output-stream) (get-descriptor-for error cookie :direction :output :if-does-not-exist :create - :if-exists if-error-exists)) + :if-exists if-error-exists + :external-format external-format)) (multiple-value-bind (pty-name pty-stream) - (open-pty pty cookie) + (open-pty pty cookie external-format) ;; Make sure we are not notified about the child death before ;; we have installed the process struct in *active-processes* (system:without-interrupts @@ -644,6 +651,7 @@ ;;; second value. ;;; (defun get-descriptor-for (object cookie &rest keys &key direction + external-format &allow-other-keys) (cond ((eq object t) ;; No new descriptor is needed. @@ -674,12 +682,16 @@ (:input (push read-fd *close-in-parent*) (push write-fd *close-on-error*) - (let ((stream (system:make-fd-stream write-fd :output t))) + (let ((stream (system:make-fd-stream write-fd :output t + :external-format + external-format))) (values read-fd stream))) (:output (push read-fd *close-on-error*) (push write-fd *close-in-parent*) - (let ((stream (system:make-fd-stream read-fd :input t))) + (let ((stream (system:make-fd-stream read-fd :input t + :external-format + external-format))) (values write-fd stream))) (t (unix:unix-close read-fd)