From f0e3d7058e208063f5f75772ec0b0944c2bf4c3c Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Mon, 30 Sep 2013 14:59:06 -0400 Subject: [PATCH] Fix run-program on LispWorks. Fix corner case on implementations that return a :bidir-stream but no :input-stream. Also test and fix support for :error-output :output. --- test/test-module-pathnames.asd | 11 --- test/test-module-pathnames.script | 86 +++++++++++--------- test/test-run-program.script | 27 +++++-- uiop/run-program.lisp | 129 ++++++++++++++++++------------ 4 files changed, 145 insertions(+), 108 deletions(-) delete mode 100644 test/test-module-pathnames.asd diff --git a/test/test-module-pathnames.asd b/test/test-module-pathnames.asd deleted file mode 100644 index e4748620..00000000 --- a/test/test-module-pathnames.asd +++ /dev/null @@ -1,11 +0,0 @@ -;;; -*- Lisp -*- - -(defsystem :test-module-pathnames - :components - ((:module "sources/level1" - :serial t - :components - ((:file "file1") - (:file "level2/file2") - (:static-file "level2/static.file") - (:static-file "test-tmp.cl"))))) diff --git a/test/test-module-pathnames.script b/test/test-module-pathnames.script index 43ce911d..1aeb3868 100644 --- a/test/test-module-pathnames.script +++ b/test/test-module-pathnames.script @@ -1,45 +1,53 @@ ;;; -*- Lisp -*- +(def-test-system :test-module-pathnames + :pathname #.*test-directory* + :components + ((:module "sources/level1" + :serial t + :components + ((:file "file1") + (:file "level2/file2") + (:static-file "level2/static.file") + (:static-file "test-tmp.cl"))))) +(asdf:load-system 'test-module-pathnames) +(flet ((pathname-foo (x) + (list (or (normalize-pathname-directory-component (pathname-directory x)) '(:relative)) + (pathname-name x) (pathname-type x)))) + (let* ((static (find-component "test-module-pathnames" '("sources/level1" "level2/static.file"))) + (test-tmp (find-component "test-module-pathnames" '("sources/level1" "test-tmp.cl")))) + (assert-equal (pathname-foo (asdf:component-relative-pathname test-tmp)) + '((:relative) "test-tmp" "cl")) + (assert-equal (pathname-foo (asdf:component-relative-pathname static)) + '((:relative "level2") "static" "file")))) +(assert (find-package :test-package) + () "package test-package not found") +(assert (find-symbol (symbol-name '*file-tmp*) :test-package) + () "symbol `*file-tmp*` not found") +(assert (symbol-value (find-symbol (symbol-name '*file-tmp*) :test-package)) + () "symbol `*file-tmp*` has wrong value") -(progn - (asdf:load-system 'test-module-pathnames) - (flet ((pathname-foo (x) - (list (or (normalize-pathname-directory-component (pathname-directory x)) '(:relative)) - (pathname-name x) (pathname-type x)))) - (let* ((static (find-component "test-module-pathnames" '("sources/level1" "level2/static.file"))) - (test-tmp (find-component "test-module-pathnames" '("sources/level1" "test-tmp.cl")))) - (assert-equal (pathname-foo (asdf:component-relative-pathname test-tmp)) - '((:relative) "test-tmp" "cl")) - (assert-equal (pathname-foo (asdf:component-relative-pathname static)) - '((:relative "level2") "static" "file")))) - (assert (find-package :test-package) - () "package test-package not found") - (assert (find-symbol (symbol-name '*file-tmp*) :test-package) - () "symbol `*file-tmp*` not found") - (assert (symbol-value (find-symbol (symbol-name '*file-tmp*) :test-package)) - () "symbol `*file-tmp*` has wrong value") +(assert (probe-file + (apply-output-translations + (merge-pathnames* + (make-pathname* + :name "file1" + :type (compile-file-type) + :directory '(:relative "sources" "level1")) + *test-directory*))) + () "compiled file not found") - (assert (probe-file - (apply-output-translations - (merge-pathnames* - (make-pathname* - :name "file1" - :type (compile-file-type) - :directory '(:relative "sources" "level1")) - *test-directory*))) - () "compiled file not found") +(assert (find-symbol (symbol-name '*file-tmp2*) :test-package) + () "symbol `*file-tmp2*` not found") +(assert (symbol-value (find-symbol (symbol-name '*file-tmp2*) :test-package)) + () "symbol `*file-tmp2*` has wrong value") - (assert (find-symbol (symbol-name '*file-tmp2*) :test-package) - () "symbol `*file-tmp2*` not found") - (assert (symbol-value (find-symbol (symbol-name '*file-tmp2*) :test-package)) - () "symbol `*file-tmp2*` has wrong value") - - (assert (probe-file - (apply-output-translations - (merge-pathnames* - (make-pathname* - :name "file2" - :type (compile-file-type) - :directory '(:relative "sources" "level1" "level2"))))) - nil "compiled file not found")) +(assert (probe-file + (apply-output-translations + (merge-pathnames* + (make-pathname* + :name "file2" + :type (compile-file-type) + :directory '(:relative "sources" "level1" "level2"))))) + nil "compiled file not found") diff --git a/test/test-run-program.script b/test/test-run-program.script index 1595e898..55c76895 100644 --- a/test/test-run-program.script +++ b/test/test-run-program.script @@ -23,7 +23,26 @@ (progn (DBG "Testing good shell command in current directory via run-shell-command") (unless (equal 0 (run-shell-command "./good-shell-command")) - (error "Failed to capture exit status indicating shell command success."))) + (error "Failed to capture exit status indicating shell command success.")) + + ;; this test checks for a problem there was in allegro -- :output :interactive + ;; would try to open T as a stream for INPUT. + (assert-equal '(nil nil 0) (multiple-value-list (run-program "true" :force-shell t :output :interactive))) + (assert-equal '(nil nil 0) (multiple-value-list (run-program "true" :force-shell nil :output :interactive))) + (assert-equal '(nil nil 1) (multiple-value-list (run-program "false" :force-shell t :output :interactive :ignore-error-status t))) + (assert-equal '(nil nil 1) (multiple-value-list (run-program "false" :force-shell nil :output :interactive :ignore-error-status t))) + (assert-equal + '("foo" "bar baz" 42) + (multiple-value-list + (run-program "cat ; echo bar baz >&2 ; exit 42" + :input '("foo") :output :string :error-output '(:string :stripped t) + :ignore-error-status t))) + (assert-equal + '(("foo" "bar" "baz" "quux") nil 0) + (multiple-value-list + (run-program "echo foo ; echo bar >&2 ; echo baz ; echo quux >& 2" + :output :lines :error-output :output)))) + ;; On Windows, normalize away CRLF into jut the unixy LF. (defun remove-cr (x) (remove (code-char 13) x)) @@ -54,12 +73,6 @@ (assert-equal "ok 1" (run-program '("echo" "ok 1") :output :line)) (assert-equal '(:ok 1) (run-program '("echo" ":ok 1") :output :forms)) (assert-equal (format nil "ok 1~%") (remove-cr (run-program '("echo" "ok 1") :output :string))) -;; this test checks for a problem there was in allegro -- :output :interactive -;; would try to open T as a stream for INPUT. -(assert-equal '(nil nil 0) (multiple-value-list (run-program "true" :force-shell t :output :interactive))) -(assert-equal '(nil nil 0) (multiple-value-list (run-program "true" :force-shell nil :output :interactive))) -(assert-equal '(nil nil 1) (multiple-value-list (run-program "false" :force-shell t :output :interactive :ignore-error-status t))) -(assert-equal '(nil nil 1) (multiple-value-list (run-program "false" :force-shell nil :output :interactive :ignore-error-status t))) ;;#+allegro (trace excl:run-shell-command sys:reap-os-subprocess) diff --git a/uiop/run-program.lisp b/uiop/run-program.lisp index 02166d73..58fde1cd 100644 --- a/uiop/run-program.lisp +++ b/uiop/run-program.lisp @@ -337,6 +337,8 @@ Programmers are encouraged to define their own methods for this generic function ;;; Internal helpers for run-program (defun %normalize-command (command) + "Given a COMMAND as a list or string, transform it in a format suitable +for the implementation's underlying run-program function" (etypecase command #+os-unix (string `("/bin/sh" "-c" ,command)) #+os-unix (list command) @@ -358,10 +360,16 @@ Programmers are encouraged to define their own methods for this generic function #-allegro command))) (defun %active-io-specifier-p (specifier) - (not (typep specifier '(or null string pathname (member :interactive :output) - #+(or cmu sbcl scl) stream)))) + "Determines whether a run-program I/O specifier requires Lisp-side processing +via SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM (return T), +or whether it's already taken care of by the implementation's underlying run-program." + (not (typep specifier '(or null string pathname (eql :interactive) + #+(or cmu sbcl scl) stream + #+lispworks file-stream)))) ;; not a type!? comm:socket-stream (defun %normalize-io-specifier (specifier &optional role) + "Normalizes a portable I/O specifier for %RUN-PROGRAM into an implementation-dependent +argument to pass to the internal RUN-PROGRAM" (declare (ignorable role)) (etypecase specifier (null (or #+(or allegro lispworks) (null-device-pathname))) @@ -389,23 +397,25 @@ Programmers are encouraged to define their own methods for this generic function (integer raw-exit-code) ; negative: signal (t -1))) - (defun %invoke-run-program (command - &rest keys - &key input (if-input-does-not-exist :error) - output (if-output-exists :overwrite) - error-output (if-error-output-exists :overwrite) - directory wait ignore-error-status - #+allegro separate-streams - &allow-other-keys) - "Runs the specified command (a list of program and arguments). - Returns a process-info plist with possible keys: + (defun %run-program (command + &rest keys + &key input (if-input-does-not-exist :error) + output (if-output-exists :overwrite) + error-output (if-error-output-exists :overwrite) + directory wait + #+allegro separate-streams + &allow-other-keys) + "A portable abstraction of a low-level call to the implementation's run-program or equivalent. +It spawns a subprocess that runs the specified COMMAND (a list of program and arguments). +INPUT, OUTPUT and ERROR-OUTPUT specify a portable IO specifer, +to be normalized by %NORMALIZE-IO-SPECIFIER. +It returns a process-info plist with possible keys: PROCESS, EXIT-CODE, INPUT-STREAM, OUTPUT-STREAM, BIDIR-STREAM, ERROR-STREAM." ;; NB: these implementations have unix vs windows set at compile-time. - (declare (ignorable ignore-error-status directory wait - if-input-does-not-exist if-output-exists if-error-output-exists)) + (declare (ignorable if-input-does-not-exist if-output-exists if-error-output-exists)) (assert (not (and wait (member :stream (list input output error-output))))) #-(or allegro clozure cmu (and lispworks os-unix) sbcl scl) - (progn command keys input output error-output + (progn command keys directory (error "run-program not available")) #+(or allegro clisp clozure cmu (and lispworks os-unix) sbcl scl) (let* ((%command (%normalize-command command)) @@ -432,9 +442,8 @@ Programmers are encouraged to define their own methods for this generic function (multiple-value-list (apply f :input %input :output %output :allow-other-keys t `(,@args ,@keys))))) - ;; since we now always return a code, that code path is unused - (assert (eq ignore-error-status t)) (assert (eq error-output :interactive)) + ;;; since we now always return a code, we can't use this code path, anyway! (etypecase %command #+os-windows (string (run 'ext:run-shell-command %command)) (list (run 'ext:run-program (car %command) @@ -460,13 +469,14 @@ Programmers are encouraged to define their own methods for this generic function :if-error-does-not-exist :create) #-sbcl keys #+sbcl (if directory keys (remove-plist-key :directory keys))))) #+(and lispworks os-unix) ;; note: only used on Unix in non-interactive case - (apply - 'system:run-shell-command - (cons "/usr/bin/env" %command) ; lispworks wants a full path. - :input %input :if-input-does-not-exist if-input-does-not-exist - :output %output :if-output-exists if-output-exists - :error %error-output :if-error-output-exists if-error-output-exists - :wait wait :save-exit-status t))) + (multiple-value-list + (apply + 'system:run-shell-command + (cons "/usr/bin/env" %command) ; lispworks wants a full path. + :input %input :if-input-does-not-exist if-input-does-not-exist + :output %output :if-output-exists if-output-exists + :error-output %error-output :if-error-output-exists if-error-output-exists + :wait wait :save-exit-status t :allow-other-keys t keys)))) (process-info-r ())) (flet ((prop (key value) (push key process-info-r) (push value process-info-r))) #+allegro @@ -499,15 +509,6 @@ Programmers are encouraged to define their own methods for this generic function (3 (prop :bidir-stream (pop process*)) (prop :input-stream (pop process*)) (prop :output-stream (pop process*)))))) - #+ecl - (destructuring-bind (stream code process) process* - (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)))) - (cond - ((zerop mode)) - ((null process*) (prop :exit-code -1)) - (t (prop (case mode (1 :input-stream) (2 :output-stream) (3 :bidir-stream)) stream)))) - (when code (prop :exit-code code)) - (when process (prop :process process))) #+(or clozure cmu sbcl scl) (progn (prop :process process*) @@ -526,6 +527,25 @@ Programmers are encouraged to define their own methods for this generic function #+clozure (ccl:external-process-error-stream process*) #+(or cmu scl) (ext:process-error process*) #+sbcl (sb-ext:process-error process*)))) + #+ecl + (destructuring-bind (stream code process) process* + (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)))) + (cond + ((zerop mode)) + ((null process*) (prop :exit-code -1)) + (t (prop (case mode (1 :input-stream) (2 :output-stream) (3 :bidir-stream)) stream)))) + (when code (prop :exit-code code)) + (when process (prop :process process))) + #+lispworks + (if wait + (prop :exit-code (first process*)) + (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)))) + (if (zerop mode) + (prop :process (first process*)) + (destructuring-bind (x err pid) process* + (prop :process pid) + (prop (ecase mode (1 :input-stream) (2 :output-stream) (3 :bidir-stream)) x) + (when (eq error-output :stream) (prop :error-stream err)))))) (nreverse process-info-r)))) (defun %wait-process-result (process-info) @@ -639,7 +659,8 @@ Programmers are encouraged to define their own methods for this generic function (assert (not (member :stream (list input output error-output)))) (let* ((active-input-p (%active-io-specifier-p input)) (active-output-p (%active-io-specifier-p output)) - (active-error-output-p (%active-io-specifier-p error-output)) + (active-error-output-p (or (eq error-output :output) + (%active-io-specifier-p error-output))) (activity (cond (active-output-p :output) @@ -652,27 +673,32 @@ Programmers are encouraged to define their own methods for this generic function output :keys keys :setf output-result :stream-easy-p t :active (eq activity :output)) (with-program-error-output ((reduced-error-output error-output-activity) - error-output :keys keys :setf error-output-result + (unless (eq error-output :output) error-output) + :keys keys :setf error-output-result :stream-easy-p t :active (eq activity :error-output)) (with-program-input ((reduced-input input-activity) input :keys keys :stream-easy-p t :active (eq activity :input)) (let ((process-info - (apply '%invoke-run-program command - :wait wait :input reduced-input - :output reduced-output :error-output reduced-error-output + (apply '%run-program command + :wait wait :input reduced-input :output reduced-output + :error-output (if (eq error-output :output) :output reduced-error-output) keys))) - (flet ((run-activity (activity stream-property) - (if-let ((stream (getf process-info stream-property))) - (funcall activity stream) - (error 'subprocess-error - :code `(:missing ,stream-property) - :command command :process process-info)))) + (labels ((get-stream (stream-name &optional fallbackp) + (or (getf process-info stream-name) + (when fallbackp + (getf process-info :bidir-stream)))) + (run-activity (activity stream-name &optional fallbackp) + (if-let (stream (get-stream stream-name fallbackp)) + (funcall activity stream) + (error 'subprocess-error + :code `(:missing ,stream-name) + :command command :process process-info)))) (unwind-protect (ecase activity ((nil)) - (:input (run-activity input-activity :input-stream)) - (:output (run-activity output-activity :output-stream)) + (:input (run-activity input-activity :input-stream t)) + (:output (run-activity output-activity :output-stream t)) (:error-output (run-activity error-output-activity :error-output-stream))) (loop :for (() val) :on process-info :by #'cddr :when (streamp val) :do (ignore-errors (close val))) @@ -712,12 +738,13 @@ Programmers are encouraged to define their own methods for this generic function (when (and directory (os-unix-p)) `("cd " (escape-shell-token directory) " ; ")) after))))) - (defun %invoke-system (command &rest keys - &key input output error-output directory &allow-other-keys) + (defun %system (command &rest keys + &key input output error-output directory &allow-other-keys) + "A portable abstraction of a low-level call to libc's system()." (declare (ignorable input output error-output directory keys)) #+(or allegro clozure cmu (and lispworks os-unix) sbcl scl) (%wait-process-result - (apply '%invoke-run-program (%normalize-system-command command) keys)) + (apply '%run-program (%normalize-system-command command) :wait t keys)) #+(or abcl clisp cormanlisp ecl gcl (and lispworks os-windows) mkcl xcl) (let ((%command (%redirected-system-command command input output error-output directory))) #+(and lispworks os-windows) @@ -748,7 +775,7 @@ Programmers are encouraged to define their own methods for this generic function error-output :keys keys :setf error-output-result) (with-program-input ((reduced-input) input :keys keys) (setf exit-code - (%check-result (apply '%invoke-system command + (%check-result (apply '%system command :input reduced-input :output reduced-output :error-output reduced-error-output keys) :command command @@ -812,7 +839,7 @@ or an indication of failure via the EXIT-CODE of the process" (apply (if (or force-shell #+(or clisp ecl) (or (not ignore-error-status) t) #+clisp (eq error-output :interactive) - #+(and lispworks os-unix) (interactivep input output error-output) + #+(and lispworks os-unix) (%interactivep input output error-output) #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) t) '%use-system '%use-run-program) command -- GitLab