From fe5cd1af557ea21675dc72c8c4c581781613025d Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sat, 10 Jun 2006 01:00:58 +0000 Subject: [PATCH] 0.9.13.40: RUN-PROGRAM tweak * If the streams passed to RUN-PRGRAM are composite streams, try to extract the underlying FD-STREAM before falling back to the tempfile/pipe strategy. --- NEWS | 5 ++ src/code/run-program.lisp | 107 +++++++++++++++++++++++------------------ tests/run-program.impure.lisp | 78 ++++++++++++++++++++++++++++-- version.lisp-expr | 2 +- 4 files changed, 139 insertions(+), 53 deletions(-) diff --git a/NEWS b/NEWS index 758d07f..e7e4853 100644 --- a/NEWS +++ b/NEWS @@ -15,6 +15,11 @@ changes in sbcl-0.9.14 relative to sbcl-0.9.13: * minor incompatible change: the :SB-LDB feature is now enabled by default, and DISABLE-DEBUGGER and ENABLE-DEBUGGER also affect the low-level debugger. + * enchancement: RUN-PROGRAM is now able to extract the file-descriptor + from SYNONYM-STREAM and TWO-WAY-STEAMS provided they can be decomposed + down to an SB-SYS:FD-STREAM, allowing direct communication in + more cases. Temporary files and pipes are still used as a fallback + strategy. * bug fix: global optimization policy was not visible in LOCALLY and MACROLET forms. * bug fix: class objects can be used as specializers in methods. diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index e4eb5ae..bf685c8 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -922,6 +922,19 @@ Common Lisp Users Manual for details about the PROCESS structure. (write-string string stream :end count))))))))))) +(defun get-stream-fd (stream direction) + (typecase stream + (sb-sys:fd-stream + (values (sb-sys:fd-stream-fd stream) nil)) + (synonym-stream + (get-stream-fd (symbol-value (synonym-stream-symbol stream)) direction)) + (two-way-stream + (ecase direction + (:input + (get-stream-fd (two-way-stream-input-stream stream) direction)) + (:output + (get-stream-fd (two-way-stream-output-stream stream) direction)))))) + ;;; Find a file descriptor to use for object given the direction. ;;; Returns the descriptor. If object is :STREAM, returns the created ;;; stream as the second value. @@ -982,56 +995,56 @@ Common Lisp Users Manual for details about the PROCESS structure. (t (error "couldn't duplicate file descriptor: ~A" (strerror errno))))))) - ((sb-sys:fd-stream-p object) - (values (sb-sys:fd-stream-fd object) nil)) ((streamp object) (ecase direction (:input - ;; FIXME: We could use a better way of setting up - ;; temporary files, both here and in LOAD-FOREIGN. - (dotimes (count - 256 - (error "could not open a temporary file in /tmp")) - (let* ((name (coerce (format nil "/tmp/.run-program-~D" count) - 'base-string)) - (fd (sb-unix:unix-open name - (logior sb-unix:o_rdwr - sb-unix:o_creat - sb-unix:o_excl) - #o666))) - (sb-unix:unix-unlink name) - (when fd - (let ((newline (string #\Newline))) - (loop - (multiple-value-bind - (line no-cr) - (read-line object nil nil) - (unless line - (return)) - (sb-unix:unix-write - fd - ;; FIXME: this really should be - ;; (STRING-TO-OCTETS :EXTERNAL-FORMAT ...). - ;; RUN-PROGRAM should take an - ;; external-format argument, which should - ;; be passed down to here. Something - ;; similar should happen on :OUTPUT, too. - (map '(vector (unsigned-byte 8)) #'char-code line) - 0 (length line)) - (if no-cr - (return) - (sb-unix:unix-write fd newline 0 1))))) - (sb-unix:unix-lseek fd 0 sb-unix:l_set) - (push fd *close-in-parent*) - (return (values fd nil)))))) + (or (get-stream-fd object :input) + ;; FIXME: We could use a better way of setting up + ;; temporary files + (dotimes (count + 256 + (error "could not open a temporary file in /tmp")) + (let* ((name (coerce (format nil "/tmp/.run-program-~D" count) + 'base-string)) + (fd (sb-unix:unix-open name + (logior sb-unix:o_rdwr + sb-unix:o_creat + sb-unix:o_excl) + #o666))) + (sb-unix:unix-unlink name) + (when fd + (let ((newline (string #\Newline))) + (loop + (multiple-value-bind + (line no-cr) + (read-line object nil nil) + (unless line + (return)) + (sb-unix:unix-write + fd + ;; FIXME: this really should be + ;; (STRING-TO-OCTETS :EXTERNAL-FORMAT ...). + ;; RUN-PROGRAM should take an + ;; external-format argument, which should + ;; be passed down to here. Something + ;; similar should happen on :OUTPUT, too. + (map '(vector (unsigned-byte 8)) #'char-code line) + 0 (length line)) + (if no-cr + (return) + (sb-unix:unix-write fd newline 0 1))))) + (sb-unix:unix-lseek fd 0 sb-unix:l_set) + (push fd *close-in-parent*) + (return (values fd nil))))))) (:output - (multiple-value-bind (read-fd write-fd) - (sb-unix:unix-pipe) - (unless read-fd - (error "couldn't create pipe: ~S" (strerror write-fd))) - (copy-descriptor-to-stream read-fd object cookie) - (push read-fd *close-on-error*) - (push write-fd *close-in-parent*) - (values write-fd nil))))) + (or (get-stream-fd object :output) + (multiple-value-bind (read-fd write-fd) + (sb-unix:unix-pipe) + (unless read-fd + (error "couldn't create pipe: ~S" (strerror write-fd))) + (copy-descriptor-to-stream read-fd object cookie) + (push read-fd *close-on-error*) + (push write-fd *close-in-parent*) + (values write-fd nil)))))) (t (error "invalid option to RUN-PROGRAM: ~S" object)))) diff --git a/tests/run-program.impure.lisp b/tests/run-program.impure.lisp index b30ade5..609976a 100644 --- a/tests/run-program.impure.lisp +++ b/tests/run-program.impure.lisp @@ -13,11 +13,11 @@ (cl:in-package :cl-user) -;; Actually there's no real side-effect here. The impurity we're -;; avoiding is the sigchld handler that RUN-PROGRAM sets up, which -;; interfers with the manual unix process control done by the test -;; framework (sometimes the handler will manage to WAIT3 a process -;; before run-tests WAITPIDs it). +;; Actually there's no real side-effect here. (But see below.) The +;; impurity we're avoiding is the sigchld handler that RUN-PROGRAM +;; sets up, which interfers with the manual unix process control done +;; by the test framework (sometimes the handler will manage to WAIT3 a +;; process before run-tests WAITPIDs it). (let* ((process (sb-ext:run-program "/bin/cat" '() :wait nil :output :stream :input :stream)) @@ -29,3 +29,71 @@ (force-output out) (assert (= (read-byte in) i))) (process-close process))) + +;;; Test driving an external program (ed) through pipes wrapped in +;;; composite streams. + +(require :sb-posix) + +(defvar *tmpfile* "run-program-ed-test.tmp") + +(with-open-file (f *tmpfile* + :direction :output + :if-exists :supersede) + (write-line "bar" f)) + +(defun make-pipe () + (multiple-value-bind (in out) (sb-posix:pipe) + (let ((input (sb-sys:make-fd-stream in + :input t + :external-format :ascii + :buffering :none :name "in")) + (output (sb-sys:make-fd-stream out + :output t + :external-format :ascii + :buffering :none :name "out"))) + (make-two-way-stream input output)))) + +(defvar *in-pipe* (make-pipe)) +(defvar *in* (make-synonym-stream '*in-pipe*)) +(defvar *out-pipe* (make-pipe)) +(defvar *out* (make-synonym-stream '*out-pipe*)) + +(defvar *ed* + (run-program "/bin/ed" (list *tmpfile*) :input *in* :output *out* :wait nil)) + +(defun real-input (stream) + (two-way-stream-input-stream (symbol-value (synonym-stream-symbol stream)))) + +(defun magic-read-line (stream) + ;; KLUDGE 1: The otherwise out :buffering :none is worth nothing, + (let ((input (real-input stream))) + (with-output-to-string (s) + ;; KLUDGE 2: Something funny going on with buffering, as plain + ;; READ-CHAR will hang here waiting for the newline, also + ;; -NO-HANG will return too early without the sleep. + ;; + ;; Shoot me now. --NS 2006-06-09 + (loop for c = (progn (sleep 0.2) (read-char-no-hang input)) + while (and c (not (eq #\newline c))) + do (write-char c s))))) + +(defun assert-ed (command response) + (when command + (write-line command *in*) + (force-output *in*)) + (let ((got (magic-read-line *out*))) + (unless (equal response got) + (error "wanted ~S from ed, got ~S" response got))) + *ed*) + +(assert-ed nil "4") +(assert-ed ".s/bar/baz/g" "") +(assert-ed "w" "4") +(assert-ed "q" "") +(process-wait *ed*) + +(with-open-file (f *tmpfile*) + (assert (equal "baz" (read-line f)))) + +;(delete-file *tmp*) diff --git a/version.lisp-expr b/version.lisp-expr index 1992f44..7676b03 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.13.39" +"0.9.13.40" -- 1.7.10.4