1 (load "test-util.lisp")
4 (:use
:cl
:test-util
:sb-ext
))
6 (load "assertoid.lisp")
10 (load "colorize.lisp")
12 (defvar *all-failures
* nil
)
13 (defvar *break-on-error
* nil
)
14 (defvar *report-skipped-tests
* nil
)
15 (defvar *explicit-test-files
* nil
)
18 (dolist (arg (cdr *posix-argv
*))
19 (cond ((string= arg
"--break-on-failure")
20 (setf *break-on-error
* t
)
21 (setf test-util
:*break-on-failure
* t
))
22 ((string= arg
"--break-on-expected-failure")
23 (setf test-util
:*break-on-expected-failure
* t
))
24 ((string= arg
"--report-skipped-tests")
25 (setf *report-skipped-tests
* t
))
26 ((string= arg
"--no-color"))
28 (push (truename (parse-namestring arg
)) *explicit-test-files
*))))
29 (setf *explicit-test-files
* (nreverse *explicit-test-files
*))
30 (pure-runner (pure-load-files) #'load-test
)
31 (pure-runner (pure-cload-files) #'cload-test
)
32 (impure-runner (impure-load-files) #'load-test
)
33 (impure-runner (impure-cload-files) #'cload-test
)
34 #-win32
(impure-runner (sh-files) #'sh-test
)
36 (sb-ext:exit
:code
(if (unexpected-failures)
42 (format t
"Finished running tests.~%")
46 (format t
"Status:~%")
47 (dolist (fail (reverse *all-failures
*))
48 (cond ((eq (car fail
) :unhandled-error
)
49 (output-colored-text (car fail
)
52 (enough-namestring (second fail
))))
53 ((eq (car fail
) :invalid-exit-status
)
54 (output-colored-text (car fail
)
55 " Invalid exit status:")
57 (enough-namestring (second fail
))))
58 ((eq (car fail
) :skipped-disabled
)
59 (when *report-skipped-tests
*
60 (format t
" ~20a ~a / ~a~%"
61 "Skipped (irrelevant):"
62 (enough-namestring (second fail
))
69 (:expected-failure
" Expected failure:")
70 (:unexpected-failure
" Failure:")
71 (:leftover-thread
" Leftover thread (broken):")
72 (:unexpected-success
" Unexpected success:")
73 (:skipped-broken
" Skipped (broken):")
74 (:skipped-disabled
" Skipped (irrelevant):")))
75 (format t
" ~a / ~a~%"
76 (enough-namestring (second fail
))
79 (format t
" (~a tests skipped for this combination of platform and features)~%"
82 (format t
"All tests succeeded~%")))))
84 (defun pure-runner (files test-fun
)
86 (format t
"// Running pure tests (~a)~%" test-fun
)
87 (let ((*package
* (find-package :cl-user
))
91 (format t
"// Running ~a~%" file
)
93 (handler-bind ((error (make-error-handler file
)))
94 (eval (funcall test-fun file
)))
98 (defun run-in-child-sbcl (load-forms forms
)
99 ;; We used to fork() for POSIX platforms, and use this for Windows.
100 ;; However, it seems better to use the same solution everywhere.
102 (#-win32 with-open-file
#-win32
(devnull "/dev/null") #+win32 progn
106 (list "--core" SB-INT
:*CORE-STRING
*
111 "--disable-debugger")
112 (loop for form in
(append load-forms forms
)
114 collect
(write-to-string form
)))
115 :output sb-sys
:*stdout
*
116 :input
#-win32 devnull
#+win32 sb-sys
:*stdin
*))))
118 (defun clear-test-status ()
119 (with-open-file (stream "test-status.lisp-expr"
121 :if-exists
:supersede
)
122 (write-line "NIL" stream
)))
124 (defun run-impure-in-child-sbcl (test-file test-code
)
129 (defpackage :run-tests
130 (:use
:cl
:test-util
:sb-ext
)))
132 `((in-package :cl-user
)
133 (use-package :test-util
)
134 (use-package :assertoid
)
135 (setf test-util
:*break-on-failure
* ,test-util
:*break-on-failure
*)
136 (setf test-util
:*break-on-expected-failure
*
137 ,test-util
:*break-on-expected-failure
*)
138 (let ((file ,test-file
)
139 (*break-on-error
* ,run-tests
::*break-on-error
*))
140 (declare (special *break-on-error
*))
141 (format t
"// Running ~a~%" file
)
144 ((error (lambda (condition)
145 (push (list :unhandled-error file
)
146 test-util
::*failures
*)
147 (cond (*break-on-error
*
148 (test-util:really-invoke-debugger condition
))
150 (format *error-output
* "~&Unhandled ~a: ~a~%"
151 (type-of condition
) condition
)
152 (sb-debug:print-backtrace
)))
153 (invoke-restart 'skip-file
))))
156 (format t
">>>~a<<<~%" test-util
::*failures
*)))
157 (test-util:report-test-status
)
158 (sb-ext:exit
:code
104)))))
160 (defun impure-runner (files test-fun
)
162 (format t
"// Running impure tests (~a)~%" test-fun
)
163 (let ((*package
* (find-package :cl-user
)))
167 (let ((exit-code (run-impure-in-child-sbcl file
168 (funcall test-fun file
))))
169 (if (= exit-code
104)
170 (with-open-file (stream "test-status.lisp-expr"
172 :if-does-not-exist
:error
)
173 (append-failures (read stream
)))
174 (push (list :invalid-exit-status file
)
175 *all-failures
*)))))))
177 (defun make-error-handler (file)
179 (push (list :unhandled-error file
) *failures
*)
180 (cond (*break-on-error
*
181 (test-util:really-invoke-debugger condition
))
183 (format *error-output
* "~&Unhandled ~a: ~a~%"
184 (type-of condition
) condition
)
185 (sb-debug:print-backtrace
)))
186 (invoke-restart 'skip-file
)))
188 (defun append-failures (&optional
(failures *failures
*))
189 (setf *all-failures
* (append failures
*all-failures
*)))
191 (defun unexpected-failures ()
192 (remove-if (lambda (x)
193 (or (eq (car x
) :expected-failure
)
194 (eq (car x
) :unexpected-success
)
195 (eq (car x
) :skipped-broken
)
196 (eq (car x
) :skipped-disabled
)))
199 (defun setup-cl-user ()
200 (use-package :test-util
)
201 (use-package :assertoid
))
203 (defun load-test (file)
204 ;; KLUDGE: while it may be the case that all test files should be opened
205 ;; as UTF-8, the 'reader' test file is particularly strange because it
206 ;; contains non-UTF-8 bytes, but the character decoding warning was not
207 ;; an intended test. It was happenstance that makes one think
208 ;; "great! there _is_ a test for character decoding errors
209 ;; in the file I would expect to find such a test in"
210 ;; except it isn't. A true test would assert something useful,
211 ;; AND not make scary meta-noise, or at least preface it with
212 ;; ";; Expect warnings from the following test"
214 ,@(if (search "reader.impure" (namestring file
))
215 '(:external-format
:latin-1
))))
218 (defun cload-test (file)
219 `(let ((compile-name (compile-file-pathname ,file
)))
225 (delete-file compile-name
)))))
227 (defun sh-test (file)
228 ;; What? No SB-POSIX:EXECV?
230 `(let ((process (sb-ext:run-program
"/bin/sh"
231 (list (native-namestring ,file
))
232 :output
*error-output
*)))
233 (let ((*failures
* nil
))
234 (test-util:report-test-status
))
235 (sb-ext:exit
:code
(process-exit-code process
))))
237 (defun filter-test-files (wild-mask)
238 (if *explicit-test-files
*
239 (loop for file in
*explicit-test-files
*
240 when
(pathname-match-p file wild-mask
)
242 (directory wild-mask
)))
244 (defun pure-load-files ()
245 (filter-test-files "*.pure.lisp"))
247 (defun pure-cload-files ()
248 (filter-test-files "*.pure-cload.lisp"))
250 (defun impure-load-files ()
251 (filter-test-files "*.impure.lisp"))
253 (defun impure-cload-files ()
254 (filter-test-files "*.impure-cload.lisp"))
257 (filter-test-files "*.test.sh"))