1 #+#.(cl:if (cl:find-package "ASDF") '(or) '(and))
4 #+#.(cl:if (cl:find-package "SB-POSIX") '(or) '(and))
5 (handler-bind (#+win32 (warning #'muffle-warning))
8 (load "test-util.lisp")
10 (defpackage :run-tests
11 (:use :cl :test-util :sb-ext))
13 (load "assertoid.lisp")
15 (in-package run-tests)
17 (load "colorize.lisp")
19 (defvar *all-failures* nil)
20 (defvar *break-on-error* nil)
21 (defvar *report-skipped-tests* nil)
22 (defvar *accept-files* nil)
25 (dolist (arg (cdr *posix-argv*))
26 (cond ((string= arg "--break-on-failure")
27 (setf *break-on-error* t)
28 (setf test-util:*break-on-failure* t))
29 ((string= arg "--break-on-expected-failure")
30 (setf test-util:*break-on-expected-failure* t))
31 ((string= arg "--report-skipped-tests")
32 (setf *report-skipped-tests* t))
33 ((string= arg "--no-color"))
35 (push (truename (parse-namestring arg)) *accept-files*))))
36 (pure-runner (pure-load-files) #'load-test)
37 (pure-runner (pure-cload-files) #'cload-test)
38 (impure-runner (impure-load-files) #'load-test)
39 (impure-runner (impure-cload-files) #'cload-test)
40 #-win32 (impure-runner (sh-files) #'sh-test)
42 (sb-ext:exit :code (if (unexpected-failures)
48 (format t "Finished running tests.~%")
52 (format t "Status:~%")
53 (dolist (fail (reverse *all-failures*))
54 (cond ((eq (car fail) :unhandled-error)
55 (output-colored-text (car fail)
58 (enough-namestring (second fail))))
59 ((eq (car fail) :invalid-exit-status)
60 (output-colored-text (car fail)
61 " Invalid exit status:")
63 (enough-namestring (second fail))))
64 ((eq (car fail) :skipped-disabled)
65 (when *report-skipped-tests*
66 (format t " ~20a ~a / ~a~%"
67 "Skipped (irrelevant):"
68 (enough-namestring (second fail))
75 (:expected-failure " Expected failure:")
76 (:unexpected-failure " Failure:")
77 (:leftover-thread " Leftover thread (broken):")
78 (:unexpected-success " Unexpected success:")
79 (:skipped-broken " Skipped (broken):")
80 (:skipped-disabled " Skipped (irrelevant):")))
81 (format t " ~a / ~a~%"
82 (enough-namestring (second fail))
85 (format t " (~a tests skipped for this combination of platform and features)~%"
88 (format t "All tests succeeded~%")))))
90 (defun pure-runner (files test-fun)
91 (format t "// Running pure tests (~a)~%" test-fun)
92 (let ((*package* (find-package :cl-user))
96 (when (accept-test-file file)
97 (format t "// Running ~a~%" file)
99 (handler-bind ((error (make-error-handler file)))
100 (eval (funcall test-fun file)))
104 (defun run-in-child-sbcl (load-forms forms)
105 ;; We used to fork() for POSIX platforms, and use this for Windows.
106 ;; However, it seems better to use the same solution everywhere.
108 (#-win32 with-open-file #-win32 (devnull "/dev/null") #+win32 progn
112 (list "--core" SB-INT:*CORE-STRING*
117 "--disable-debugger")
118 (loop for form in (append load-forms forms)
120 collect (write-to-string form)))
121 :output sb-sys:*stdout*
122 :input #-win32 devnull #+win32 sb-sys:*stdin*))))
124 (defun run-impure-in-child-sbcl (test-file test-code)
128 (defpackage :run-tests
129 (:use :cl :test-util :sb-ext)))
131 `((in-package :cl-user)
132 (use-package :test-util)
133 (use-package :assertoid)
134 (setf test-util:*break-on-failure* ,test-util:*break-on-failure*)
135 (setf test-util:*break-on-expected-failure*
136 ,test-util:*break-on-expected-failure*)
137 (let ((file ,test-file)
138 (*break-on-error* ,run-tests::*break-on-error*))
139 (declare (special *break-on-error*))
140 (format t "// Running ~a~%" file)
143 ((error (lambda (condition)
144 (push (list :unhandled-error file)
145 test-util::*failures*)
146 (cond (*break-on-error*
147 (test-util:really-invoke-debugger condition))
149 (format *error-output* "~&Unhandled ~a: ~a~%"
150 (type-of condition) condition)
151 (sb-debug:print-backtrace)))
152 (invoke-restart 'skip-file))))
155 (format t ">>>~a<<<~%" test-util::*failures*)))
156 (test-util:report-test-status)
157 (sb-ext:exit :code 104)))))
159 (defun impure-runner (files test-fun)
160 (format t "// Running impure tests (~a)~%" test-fun)
161 (let ((*package* (find-package :cl-user)))
164 (when (accept-test-file file)
166 (let ((exit-code (run-impure-in-child-sbcl file
167 (funcall test-fun file))))
168 (if (= exit-code 104)
169 (with-open-file (stream "test-status.lisp-expr"
171 :if-does-not-exist :error)
172 (append-failures (read stream)))
173 (push (list :invalid-exit-status file)
174 *all-failures*)))))))
176 (defun make-error-handler (file)
178 (push (list :unhandled-error file) *failures*)
179 (cond (*break-on-error*
180 (test-util:really-invoke-debugger condition))
182 (format *error-output* "~&Unhandled ~a: ~a~%"
183 (type-of condition) condition)
184 (sb-debug:print-backtrace)))
185 (invoke-restart 'skip-file)))
187 (defun append-failures (&optional (failures *failures*))
188 (setf *all-failures* (append failures *all-failures*)))
190 (defun unexpected-failures ()
191 (remove-if (lambda (x)
192 (or (eq (car x) :expected-failure)
193 (eq (car x) :unexpected-success)
194 (eq (car x) :skipped-broken)
195 (eq (car x) :skipped-disabled)))
198 (defun setup-cl-user ()
199 (use-package :test-util)
200 (use-package :assertoid))
202 (defun load-test (file)
205 (defun cload-test (file)
206 `(let ((compile-name (compile-file-pathname ,file)))
212 (delete-file compile-name)))))
214 (defun sh-test (file)
215 ;; What? No SB-POSIX:EXECV?
216 `(let ((process (sb-ext:run-program "/bin/sh"
217 (list (native-namestring ,file))
218 :environment (test-util::test-env)
219 :output *error-output*)))
220 (let ((*failures* nil))
221 (test-util:report-test-status))
222 (sb-ext:exit :code (process-exit-code process))))
224 (defun accept-test-file (file)
226 (find (truename file) *accept-files* :test #'equalp)
229 (defun pure-load-files ()
230 (directory "*.pure.lisp"))
232 (defun pure-cload-files ()
233 (directory "*.pure-cload.lisp"))
235 (defun impure-load-files ()
236 (directory "*.impure.lisp"))
238 (defun impure-cload-files ()
239 (directory "*.impure-cload.lisp"))
242 (directory "*.test.sh"))