Commit f0e3d705 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

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
;;; -*- 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 -*-
(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")
......@@ -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)
......
This diff is collapsed.
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