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