Skip to content
Snippets Groups Projects
Commit f0e3d705 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

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.
parent 82efc2a4
No related branches found
No related tags found
No related merge requests found
;;; -*- 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")))))
;;; -*- Lisp -*- ;;; -*- 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 (assert (probe-file
(asdf:load-system 'test-module-pathnames) (apply-output-translations
(flet ((pathname-foo (x) (merge-pathnames*
(list (or (normalize-pathname-directory-component (pathname-directory x)) '(:relative)) (make-pathname*
(pathname-name x) (pathname-type x)))) :name "file1"
(let* ((static (find-component "test-module-pathnames" '("sources/level1" "level2/static.file"))) :type (compile-file-type)
(test-tmp (find-component "test-module-pathnames" '("sources/level1" "test-tmp.cl")))) :directory '(:relative "sources" "level1"))
(assert-equal (pathname-foo (asdf:component-relative-pathname test-tmp)) *test-directory*)))
'((:relative) "test-tmp" "cl")) () "compiled file not found")
(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 (assert (find-symbol (symbol-name '*file-tmp2*) :test-package)
(apply-output-translations () "symbol `*file-tmp2*` not found")
(merge-pathnames* (assert (symbol-value (find-symbol (symbol-name '*file-tmp2*) :test-package))
(make-pathname* () "symbol `*file-tmp2*` has wrong value")
: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) (assert (probe-file
() "symbol `*file-tmp2*` not found") (apply-output-translations
(assert (symbol-value (find-symbol (symbol-name '*file-tmp2*) :test-package)) (merge-pathnames*
() "symbol `*file-tmp2*` has wrong value") (make-pathname*
:name "file2"
(assert (probe-file :type (compile-file-type)
(apply-output-translations :directory '(:relative "sources" "level1" "level2")))))
(merge-pathnames* nil "compiled file not found")
(make-pathname*
:name "file2"
:type (compile-file-type)
:directory '(:relative "sources" "level1" "level2")))))
nil "compiled file not found"))
...@@ -23,7 +23,26 @@ ...@@ -23,7 +23,26 @@
(progn (progn
(DBG "Testing good shell command in current directory via run-shell-command") (DBG "Testing good shell command in current directory via run-shell-command")
(unless (equal 0 (run-shell-command "./good-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. ;; On Windows, normalize away CRLF into jut the unixy LF.
(defun remove-cr (x) (remove (code-char 13) x)) (defun remove-cr (x) (remove (code-char 13) x))
...@@ -54,12 +73,6 @@ ...@@ -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 :line))
(assert-equal '(:ok 1) (run-program '("echo" ":ok 1") :output :forms)) (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))) (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) ;;#+allegro (trace excl:run-shell-command sys:reap-os-subprocess)
......
...@@ -337,6 +337,8 @@ Programmers are encouraged to define their own methods for this generic function ...@@ -337,6 +337,8 @@ Programmers are encouraged to define their own methods for this generic function
;;; Internal helpers for run-program ;;; Internal helpers for run-program
(defun %normalize-command (command) (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 (etypecase command
#+os-unix (string `("/bin/sh" "-c" ,command)) #+os-unix (string `("/bin/sh" "-c" ,command))
#+os-unix (list command) #+os-unix (list command)
...@@ -358,10 +360,16 @@ Programmers are encouraged to define their own methods for this generic function ...@@ -358,10 +360,16 @@ Programmers are encouraged to define their own methods for this generic function
#-allegro command))) #-allegro command)))
(defun %active-io-specifier-p (specifier) (defun %active-io-specifier-p (specifier)
(not (typep specifier '(or null string pathname (member :interactive :output) "Determines whether a run-program I/O specifier requires Lisp-side processing
#+(or cmu sbcl scl) stream)))) 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) (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)) (declare (ignorable role))
(etypecase specifier (etypecase specifier
(null (or #+(or allegro lispworks) (null-device-pathname))) (null (or #+(or allegro lispworks) (null-device-pathname)))
...@@ -389,23 +397,25 @@ Programmers are encouraged to define their own methods for this generic function ...@@ -389,23 +397,25 @@ Programmers are encouraged to define their own methods for this generic function
(integer raw-exit-code) ; negative: signal (integer raw-exit-code) ; negative: signal
(t -1))) (t -1)))
(defun %invoke-run-program (command (defun %run-program (command
&rest keys &rest keys
&key input (if-input-does-not-exist :error) &key input (if-input-does-not-exist :error)
output (if-output-exists :overwrite) output (if-output-exists :overwrite)
error-output (if-error-output-exists :overwrite) error-output (if-error-output-exists :overwrite)
directory wait ignore-error-status directory wait
#+allegro separate-streams #+allegro separate-streams
&allow-other-keys) &allow-other-keys)
"Runs the specified command (a list of program and arguments). "A portable abstraction of a low-level call to the implementation's run-program or equivalent.
Returns a process-info plist with possible keys: 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." PROCESS, EXIT-CODE, INPUT-STREAM, OUTPUT-STREAM, BIDIR-STREAM, ERROR-STREAM."
;; NB: these implementations have unix vs windows set at compile-time. ;; NB: these implementations have unix vs windows set at compile-time.
(declare (ignorable ignore-error-status directory wait (declare (ignorable if-input-does-not-exist if-output-exists if-error-output-exists))
if-input-does-not-exist if-output-exists if-error-output-exists))
(assert (not (and wait (member :stream (list input output error-output))))) (assert (not (and wait (member :stream (list input output error-output)))))
#-(or allegro clozure cmu (and lispworks os-unix) sbcl scl) #-(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")) (error "run-program not available"))
#+(or allegro clisp clozure cmu (and lispworks os-unix) sbcl scl) #+(or allegro clisp clozure cmu (and lispworks os-unix) sbcl scl)
(let* ((%command (%normalize-command command)) (let* ((%command (%normalize-command command))
...@@ -432,9 +442,8 @@ Programmers are encouraged to define their own methods for this generic function ...@@ -432,9 +442,8 @@ Programmers are encouraged to define their own methods for this generic function
(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)))))
;; since we now always return a code, that code path is unused
(assert (eq ignore-error-status t))
(assert (eq error-output :interactive)) (assert (eq error-output :interactive))
;;; 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))
(list (run 'ext:run-program (car %command) (list (run 'ext:run-program (car %command)
...@@ -460,13 +469,14 @@ Programmers are encouraged to define their own methods for this generic function ...@@ -460,13 +469,14 @@ Programmers are encouraged to define their own methods for this generic function
:if-error-does-not-exist :create) :if-error-does-not-exist :create)
#-sbcl keys #+sbcl (if directory keys (remove-plist-key :directory keys))))) #-sbcl keys #+sbcl (if directory keys (remove-plist-key :directory keys)))))
#+(and lispworks os-unix) ;; note: only used on Unix in non-interactive case #+(and lispworks os-unix) ;; note: only used on Unix in non-interactive case
(apply (multiple-value-list
'system:run-shell-command (apply
(cons "/usr/bin/env" %command) ; lispworks wants a full path. 'system:run-shell-command
:input %input :if-input-does-not-exist if-input-does-not-exist (cons "/usr/bin/env" %command) ; lispworks wants a full path.
:output %output :if-output-exists if-output-exists :input %input :if-input-does-not-exist if-input-does-not-exist
:error %error-output :if-error-output-exists if-error-output-exists :output %output :if-output-exists if-output-exists
:wait wait :save-exit-status t))) :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 ())) (process-info-r ()))
(flet ((prop (key value) (push key process-info-r) (push value process-info-r))) (flet ((prop (key value) (push key process-info-r) (push value process-info-r)))
#+allegro #+allegro
...@@ -499,15 +509,6 @@ Programmers are encouraged to define their own methods for this generic function ...@@ -499,15 +509,6 @@ Programmers are encouraged to define their own methods for this generic function
(3 (prop :bidir-stream (pop process*)) (3 (prop :bidir-stream (pop process*))
(prop :input-stream (pop process*)) (prop :input-stream (pop process*))
(prop :output-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) #+(or clozure cmu sbcl scl)
(progn (progn
(prop :process process*) (prop :process process*)
...@@ -526,6 +527,25 @@ Programmers are encouraged to define their own methods for this generic function ...@@ -526,6 +527,25 @@ Programmers are encouraged to define their own methods for this generic function
#+clozure (ccl:external-process-error-stream process*) #+clozure (ccl:external-process-error-stream process*)
#+(or cmu scl) (ext:process-error process*) #+(or cmu scl) (ext:process-error process*)
#+sbcl (sb-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)))) (nreverse process-info-r))))
(defun %wait-process-result (process-info) (defun %wait-process-result (process-info)
...@@ -639,7 +659,8 @@ Programmers are encouraged to define their own methods for this generic function ...@@ -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)))) (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 (%active-io-specifier-p error-output)) (active-error-output-p (or (eq error-output :output)
(%active-io-specifier-p error-output)))
(activity (activity
(cond (cond
(active-output-p :output) (active-output-p :output)
...@@ -652,27 +673,32 @@ Programmers are encouraged to define their own methods for this generic function ...@@ -652,27 +673,32 @@ Programmers are encouraged to define their own methods for this generic function
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)
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)) :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
:stream-easy-p t :active (eq activity :input)) :stream-easy-p t :active (eq activity :input))
(let ((process-info (let ((process-info
(apply '%invoke-run-program command (apply '%run-program command
:wait wait :input reduced-input :wait wait :input reduced-input :output reduced-output
:output reduced-output :error-output reduced-error-output :error-output (if (eq error-output :output) :output reduced-error-output)
keys))) keys)))
(flet ((run-activity (activity stream-property) (labels ((get-stream (stream-name &optional fallbackp)
(if-let ((stream (getf process-info stream-property))) (or (getf process-info stream-name)
(funcall activity stream) (when fallbackp
(error 'subprocess-error (getf process-info :bidir-stream))))
:code `(:missing ,stream-property) (run-activity (activity stream-name &optional fallbackp)
:command command :process process-info)))) (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 (unwind-protect
(ecase activity (ecase activity
((nil)) ((nil))
(:input (run-activity input-activity :input-stream)) (:input (run-activity input-activity :input-stream t))
(:output (run-activity output-activity :output-stream)) (:output (run-activity output-activity :output-stream t))
(:error-output (run-activity error-output-activity :error-output-stream))) (:error-output (run-activity error-output-activity :error-output-stream)))
(loop :for (() val) :on process-info :by #'cddr (loop :for (() val) :on process-info :by #'cddr
:when (streamp val) :do (ignore-errors (close val))) :when (streamp val) :do (ignore-errors (close val)))
...@@ -712,12 +738,13 @@ Programmers are encouraged to define their own methods for this generic function ...@@ -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) " ; ")) (when (and directory (os-unix-p)) `("cd " (escape-shell-token directory) " ; "))
after))))) after)))))
(defun %invoke-system (command &rest keys (defun %system (command &rest keys
&key input output error-output directory &allow-other-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)) (declare (ignorable input output error-output directory keys))
#+(or allegro clozure cmu (and lispworks os-unix) sbcl scl) #+(or allegro clozure cmu (and lispworks os-unix) sbcl scl)
(%wait-process-result (%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) #+(or abcl clisp cormanlisp ecl gcl (and lispworks os-windows) mkcl xcl)
(let ((%command (%redirected-system-command command input output error-output directory))) (let ((%command (%redirected-system-command command input output error-output directory)))
#+(and lispworks os-windows) #+(and lispworks os-windows)
...@@ -748,7 +775,7 @@ Programmers are encouraged to define their own methods for this generic function ...@@ -748,7 +775,7 @@ Programmers are encouraged to define their own methods for this generic function
error-output :keys keys :setf error-output-result) error-output :keys keys :setf error-output-result)
(with-program-input ((reduced-input) input :keys keys) (with-program-input ((reduced-input) input :keys keys)
(setf exit-code (setf exit-code
(%check-result (apply '%invoke-system command (%check-result (apply '%system command
:input reduced-input :output reduced-output :input reduced-input :output reduced-output
:error-output reduced-error-output keys) :error-output reduced-error-output keys)
:command command :command command
...@@ -812,7 +839,7 @@ or an indication of failure via the EXIT-CODE of the process" ...@@ -812,7 +839,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)
#+(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)
command command
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment