Commit 24483f02 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Fall back to %use-system where :error-output :output isn't supported (ABCL, CLISP).

Fix missing quote for stderr on allegro.
parent 02aaf3e8
...@@ -37,7 +37,6 @@ ...@@ -37,7 +37,6 @@
(run-program "cat ; echo bar baz >&2 ; exit 42" (run-program "cat ; echo bar baz >&2 ; exit 42"
:input '("foo") :output :string :error-output '(:string :stripped t) :input '("foo") :output :string :error-output '(:string :stripped t)
:ignore-error-status t))) :ignore-error-status t)))
#-abcl
(assert-equal (assert-equal
'(("foo" "bar" "baz" "quux") nil 0) '(("foo" "bar" "baz" "quux") nil 0)
(multiple-value-list (multiple-value-list
......
...@@ -363,7 +363,7 @@ for the implementation's underlying run-program function" ...@@ -363,7 +363,7 @@ for the implementation's underlying run-program function"
"Determines whether a run-program I/O specifier requires Lisp-side processing "Determines whether a run-program I/O specifier requires Lisp-side processing
via SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM (return T), 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." or whether it's already taken care of by the implementation's underlying run-program."
(not (typep specifier '(or null string pathname (eql :interactive) (not (typep specifier '(or null string pathname (member :interactive :output)
#+(or cmu sbcl scl) stream #+(or cmu sbcl scl) stream
#+lispworks file-stream)))) ;; not a type!? comm:socket-stream #+lispworks file-stream)))) ;; not a type!? comm:socket-stream
...@@ -442,7 +442,7 @@ It returns a process-info plist with possible keys: ...@@ -442,7 +442,7 @@ It returns a process-info plist with possible keys:
(multiple-value-list (multiple-value-list
(apply f :input %input :output %output (apply f :input %input :output %output
:allow-other-keys t `(,@args ,@keys))))) :allow-other-keys t `(,@args ,@keys)))))
(assert (eq error-output :interactive)) (assert (eq %error-output :terminal))
;;; since we now always return a code, we can't use this code path, anyway! ;;; since we now always return a code, we can't use this code path, anyway!
(etypecase %command (etypecase %command
#+os-windows (string (run 'ext:run-shell-command %command)) #+os-windows (string (run 'ext:run-shell-command %command))
...@@ -580,7 +580,7 @@ It returns a process-info plist with possible keys: ...@@ -580,7 +580,7 @@ It returns a process-info plist with possible keys:
;; GF is the generic function to call to handle arbitrary values of SPEC ;; GF is the generic function to call to handle arbitrary values of SPEC
;; STREAM-EASY-P is T if we're going to use a RUN-PROGRAM that copies streams in the background ;; STREAM-EASY-P is T if we're going to use a RUN-PROGRAM that copies streams in the background
;; (it's only meaningful on CMUCL, SBCL, SCL that actually do it) ;; (it's only meaningful on CMUCL, SBCL, SCL that actually do it)
;; DIRECTION is :INPUT or :OUTPUT for the direction of this io argument ;; DIRECTION is :INPUT, :OUTPUT or :ERROR-OUTPUT for the direction of this io argument
;; FUN is a function of the new reduced spec and an activity function to call with a stream ;; FUN is a function of the new reduced spec and an activity function to call with a stream
;; when the subprocess is active and communicating through that stream. ;; when the subprocess is active and communicating through that stream.
;; ACTIVEP is a boolean true if we will get to run code while the process is running ;; ACTIVEP is a boolean true if we will get to run code while the process is running
...@@ -588,36 +588,46 @@ It returns a process-info plist with possible keys: ...@@ -588,36 +588,46 @@ It returns a process-info plist with possible keys:
;; RETURNER is a function called with the value of the activity. ;; RETURNER is a function called with the value of the activity.
;; --- TODO (fare@tunes.org): handle if-output-exists and such when doing it the hard way. ;; --- TODO (fare@tunes.org): handle if-output-exists and such when doing it the hard way.
(declare (ignorable stream-easy-p)) (declare (ignorable stream-easy-p))
(when (eq spec t) (setf spec tval)) (let* ((actual-spec (if (eq spec t) tval spec))
(labels ((activity (stream) (activity-spec (if (eq actual-spec :output)
(call-function returner (call-stream-processor gf spec stream))) (ecase direction
(easy-case () ((:input :output)
(funcall fun spec nil)) (error "~S not allowed as a ~S ~S spec"
(hard-case () :output 'run-program direction))
(if activep ((:error-output)
(funcall fun :stream #'activity) nil))
(with-temporary-file (:pathname tmp :stream s actual-spec)))
:direction (ecase direction (:input :output) (:output :io)) (labels ((activity (stream)
:element-type element-type (call-function returner (call-stream-processor gf activity-spec stream)))
:external-format external-format) (easy-case ()
(ecase direction (funcall fun actual-spec nil))
(:input ;; for input (hard-case ()
(unwind-protect (activity s) (if activep
(ignore-errors (close s))) (funcall fun :stream #'activity)
(funcall fun tmp nil)) (with-temporary-file (:pathname tmp :stream s
(:output ;; for output, error-output :direction (ecase direction
(unwind-protect ((:input) :output)
(multiple-value-prog1 (funcall fun tmp nil) ((:output :error-output) :io))
(activity s)) :element-type element-type
(ignore-errors (close s))))))))) :external-format external-format)
(typecase spec (ecase direction
((or null string pathname (eql :interactive)) (:input
(easy-case)) (unwind-protect (activity s)
#+(or cmu sbcl scl) ;; streams are only easy on implementations that try very hard (ignore-errors (close s)))
(stream (funcall fun tmp nil))
(if stream-easy-p (easy-case) (hard-case))) ((:output :error-output)
(t (unwind-protect
(hard-case))))) (multiple-value-prog1 (funcall fun tmp nil)
(activity s))
(ignore-errors (close s)))))))))
(typecase activity-spec
((or null string pathname (eql :interactive))
(easy-case))
#+(or cmu sbcl scl) ;; streams are only easy on implementations that try very hard
(stream
(if stream-easy-p (easy-case) (hard-case)))
(t
(hard-case))))))
(defmacro place-setter (place) (defmacro place-setter (place)
(when place (when place
...@@ -650,7 +660,7 @@ It returns a process-info plist with possible keys: ...@@ -650,7 +660,7 @@ It returns a process-info plist with possible keys:
#'(lambda (,reduced-error-output-var ,error-output-activity-var) #'(lambda (,reduced-error-output-var ,error-output-activity-var)
,@(unless eoavp `((declare (ignore ,error-output-activity-var)))) ,@(unless eoavp `((declare (ignore ,error-output-activity-var))))
,@body) ,@body)
:output ,error-output-form ,active (place-setter ,setf) ,keys)) :error-output ,error-output-form ,active (place-setter ,setf) ,keys))
(defun %use-run-program (command &rest keys (defun %use-run-program (command &rest keys
&key input output error-output ignore-error-status &allow-other-keys) &key input output error-output ignore-error-status &allow-other-keys)
...@@ -659,8 +669,7 @@ It returns a process-info plist with possible keys: ...@@ -659,8 +669,7 @@ It returns a process-info plist with possible keys:
(assert (not (member :stream (list input output error-output)))) (assert (not (member :stream (list input output error-output))))
(let* ((active-input-p (%active-io-specifier-p input)) (let* ((active-input-p (%active-io-specifier-p input))
(active-output-p (%active-io-specifier-p output)) (active-output-p (%active-io-specifier-p output))
(active-error-output-p (or (eq error-output :output) (active-error-output-p (%active-io-specifier-p error-output))
(%active-io-specifier-p error-output)))
(activity (activity
(cond (cond
(active-output-p :output) (active-output-p :output)
...@@ -673,8 +682,7 @@ It returns a process-info plist with possible keys: ...@@ -673,8 +682,7 @@ It returns a process-info plist with possible keys:
output :keys keys :setf output-result output :keys keys :setf output-result
:stream-easy-p t :active (eq activity :output)) :stream-easy-p t :active (eq activity :output))
(with-program-error-output ((reduced-error-output error-output-activity) (with-program-error-output ((reduced-error-output error-output-activity)
(unless (eq error-output :output) error-output) error-output :keys keys :setf error-output-result
:keys keys :setf error-output-result
:stream-easy-p t :active (eq activity :error-output)) :stream-easy-p t :active (eq activity :error-output))
(with-program-input ((reduced-input input-activity) (with-program-input ((reduced-input input-activity)
input :keys keys input :keys keys
...@@ -839,6 +847,7 @@ or an indication of failure via the EXIT-CODE of the process" ...@@ -839,6 +847,7 @@ or an indication of failure via the EXIT-CODE of the process"
(apply (if (or force-shell (apply (if (or force-shell
#+(or clisp ecl) (or (not ignore-error-status) t) #+(or clisp ecl) (or (not ignore-error-status) t)
#+clisp (eq error-output :interactive) #+clisp (eq error-output :interactive)
#+(or abcl clisp) (eq :error-output :output)
#+(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) #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) t)
'%use-system '%use-run-program) '%use-system '%use-run-program)
......
...@@ -63,7 +63,7 @@ ...@@ -63,7 +63,7 @@
(defun setup-stderr () (defun setup-stderr ()
(setf *stderr* (setf *stderr*
#.(or #+allegro excl::*stderr* #.(or #+allegro 'excl::*stderr*
#+clozure 'ccl::*stderr* #+clozure 'ccl::*stderr*
#+(or cmu scl) 'system:*stderr* #+(or cmu scl) 'system:*stderr*
#+ecl 'ext::+process-error-output+ #+ecl 'ext::+process-error-output+
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment