Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 296 lines (257 sloc) 12.58 kb
869a1f5 @sionescu Fix modelines
authored
1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
2
55740ed @sionescu Use lowercase-only characters for package names to fix compilation on Al...
authored
3 (in-package :it.bese.fiveam)
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
4
5 ;;;; * Running Tests
6
7 ;;;; Once the programmer has defined what the tests are these need to
8 ;;;; be run and the expected effects should be compared with the
9 ;;;; actual effects. FiveAM provides the function RUN for this
10 ;;;; purpose, RUN executes a number of tests and collects the results
11 ;;;; of each individual check into a list which is then
12 ;;;; returned. There are three types of test results: passed, failed
13 ;;;; and skipped, these are represented by TEST-RESULT objects.
14
15 ;;;; Generally running a test will return normally, but there are two
16 ;;;; exceptional situations which can occur:
17
18 ;;;; - An exception is signaled while running the test. If the
19 ;;;; variable *debug-on-error* is T than FiveAM will enter the
20 ;;;; debugger, otherwise a test failure (of type
21 ;;;; unexpected-test-failure) is returned. When entering the
22 ;;;; debugger two restarts are made available, one simply reruns the
23 ;;;; current test and another signals a test-failure and continues
24 ;;;; with the remaining tests.
25
26 ;;;; - A circular dependency is detected. An error is signaled and a
27 ;;;; restart is made available which signals a test-skipped and
28 ;;;; continues with the remaining tests. This restart also sets the
29 ;;;; dependency status of the test to nil, so any tests which depend
30 ;;;; on this one (even if the dependency is not circular) will be
31 ;;;; skipped.
32
33 ;;;; The functions RUN!, !, !! and !!! are convenient wrappers around
34 ;;;; RUN and EXPLAIN.
35
585f4cd @segv The default value of *debug-on-error* should be NIL, not T
segv authored
36 (defparameter *debug-on-error* nil
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
37 "T if we should drop into a debugger on error, NIL otherwise.")
38
b946ea0 @pg314 alternative implementation of *debug-on-failure* (without spurious call ...
pg314 authored
39 (defparameter *debug-on-failure* nil
40 "T if we should drop into a debugger on a failing check, NIL otherwise.")
41
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
42 (defun import-testing-symbols (package-designator)
43 (import '(5am::is 5am::is-true 5am::is-false 5am::signals 5am::finishes)
1b24abf @sionescu Fix indentation, whitespace
authored
44 package-designator))
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
45
46 (defparameter *run-queue* '()
47 "List of test waiting to be run.")
48
49 (define-condition circular-dependency (error)
50 ((test-case :initarg :test-case))
51 (:report (lambda (cd stream)
52 (format stream "A circular dependency wes detected in ~S." (slot-value cd 'test-case))))
53 (:documentation "Condition signaled when a circular dependency
54 between test-cases has been detected."))
55
56 (defgeneric run-resolving-dependencies (test)
57 (:documentation "Given a dependency spec determine if the spec
58 is satisfied or not, this will generally involve running other
c7667c4 @sionescu Fix typo
authored
59 tests. If the dependency spec can be satisfied the test is also
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
60 run."))
61
62 (defmethod run-resolving-dependencies ((test test-case))
63 "Return true if this test, and its dependencies, are satisfied,
64 NIL otherwise."
65 (case (status test)
66 (:unknown
67 (setf (status test) :resolving)
68 (if (or (not (depends-on test))
aeda92b depends-on with single symbol resolves dependencies ok
Henrik Hjelte authored
69 (eql t (resolve-dependencies (depends-on test))))
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
70 (progn
71 (run-test-lambda test)
72 (status test))
73 (with-run-state (result-list)
74 (unless (eql :circular (status test))
75 (push (make-instance 'test-skipped
76 :test-case test
77 :reason "Dependencies not satisfied")
78 result-list)
1b24abf @sionescu Fix indentation, whitespace
authored
79 (setf (status test) :depends-not-satisfied)))))
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
80 (:resolving
81 (restart-case
82 (error 'circular-dependency :test-case test)
83 (skip ()
1b24abf @sionescu Fix indentation, whitespace
authored
84 :report (lambda (s)
85 (format s "Skip the test ~S and all its dependencies." (name test)))
86 (with-run-state (result-list)
87 (push (make-instance 'test-skipped :reason "Circular dependencies" :test-case test)
88 result-list))
89 (setf (status test) :circular))))
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
90 (t (status test))))
91
4460cad @sionescu Use DEFGENERIC
authored
92 (defgeneric resolve-dependencies (depends-on))
93
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
94 (defmethod resolve-dependencies ((depends-on symbol))
95 "A test which depends on a symbol is interpreted as `(AND
96 ,DEPENDS-ON)."
97 (run-resolving-dependencies (get-test depends-on)))
98
99 (defmethod resolve-dependencies ((depends-on list))
100 "Return true if the dependency spec DEPENDS-ON is satisfied,
101 nil otherwise."
102 (if (null depends-on)
103 t
104 (flet ((satisfies-depends-p (test)
1b24abf @sionescu Fix indentation, whitespace
authored
105 (funcall test (lambda (dep)
106 (eql t (resolve-dependencies dep)))
107 (cdr depends-on))))
108 (ecase (car depends-on)
109 (and (satisfies-depends-p #'every))
110 (or (satisfies-depends-p #'some))
111 (not (satisfies-depends-p #'notany))
ef75e7e added :before depends-on option
Henrik Hjelte authored
112 (:before (every #'(lambda (dep)
113 (let ((status (status (get-test dep))))
114 (eql :unknown status)))
1b24abf @sionescu Fix indentation, whitespace
authored
115 (cdr depends-on)))))))
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
116
117 (defun results-status (result-list)
118 "Given a list of test results (generated while running a test)
119 return true if all of the results are of type TEST-PASSED,
120 faile otherwise."
121 (every (lambda (res)
1b24abf @sionescu Fix indentation, whitespace
authored
122 (typep res 'test-passed))
123 result-list))
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
124
125 (defun return-result-list (test-lambda)
126 "Run the test function TEST-LAMBDA and return a list of all
127 test results generated, does not modify the special environment
128 variable RESULT-LIST."
1b24abf @sionescu Fix indentation, whitespace
authored
129 (bind-run-state ((result-list '()))
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
130 (funcall test-lambda)
131 result-list))
132
4460cad @sionescu Use DEFGENERIC
authored
133 (defgeneric run-test-lambda (test))
134
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
135 (defmethod run-test-lambda ((test test-case))
136 (with-run-state (result-list)
287c9bb @segv Fix bugs in the handling and reporting of unexpected errors
segv authored
137 (bind-run-state ((current-test test))
138 (labels ((abort-test (e)
1552475 @segv minor indentation fix
segv authored
139 (add-result 'unexpected-test-failure
140 :test-expr nil
141 :test-case test
5ff307e Princ-ing of Unexpected Error
Kilian Sprotte authored
142 :reason (format nil "Unexpected Error: ~S~%~A." e e)
1552475 @segv minor indentation fix
segv authored
143 :condition e))
287c9bb @segv Fix bugs in the handling and reporting of unexpected errors
segv authored
144 (run-it ()
145 (let ((result-list '()))
146 (declare (special result-list))
b946ea0 @pg314 alternative implementation of *debug-on-failure* (without spurious call ...
pg314 authored
147 (handler-bind ((check-failure (lambda (e)
148 (declare (ignore e))
149 (unless *debug-on-failure*
150 (invoke-restart
151 (find-restart 'ignore-failure)))))
152 (error (lambda (e)
153 (unless (or *debug-on-error*
154 (typep e 'check-failure))
287c9bb @segv Fix bugs in the handling and reporting of unexpected errors
segv authored
155 (abort-test e)
156 (return-from run-it result-list)))))
157 (restart-case
fdc0991 @attila-lendvai FIX: Store *package* at definition time for tests and rebind it at runti...
attila-lendvai authored
158 (let ((*readtable* (copy-readtable))
159 (*package* (runtime-package test)))
8e2b8ea @segv Add support for collecting profiling information during test runs.
segv authored
160 (if (collect-profiling-info test)
a3a3f45 @sionescu Drop dependency on Arnesi, use Alexandria instead
authored
161 ;; Timing info doesn't get collected ATM, we need a portable library
162 ;; (setf (profiling-info test) (collect-timing (test-lambda test)))
163 (funcall (test-lambda test))
8e2b8ea @segv Add support for collecting profiling information during test runs.
segv authored
164 (funcall (test-lambda test))))
287c9bb @segv Fix bugs in the handling and reporting of unexpected errors
segv authored
165 (retest ()
166 :report (lambda (stream)
167 (format stream "~@<Rerun the test ~S~@:>" test))
168 (return-from run-it (run-it)))
169 (ignore ()
170 :report (lambda (stream)
7caced9 @segv Fix a few typos in the docs. (Reported by: Peter Gijsels <peter.gijsels@...
segv authored
171 (format stream "~@<Signal an exceptional test failure and abort the test ~S.~@:>" test))
287c9bb @segv Fix bugs in the handling and reporting of unexpected errors
segv authored
172 (abort-test (make-instance 'test-failure :test-case test
173 :reason "Failure restart."))))
174 result-list))))
175 (let ((results (run-it)))
176 (setf (status test) (results-status results)
177 result-list (nconc result-list results)))))))
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
178
179 (defgeneric %run (test-spec)
180 (:documentation "Internal method for running a test. Does not
1b24abf @sionescu Fix indentation, whitespace
authored
181 update the status of the tests nor the special variables !,
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
182 !!, !!!"))
183
184 (defmethod %run ((test test-case))
185 (run-resolving-dependencies test))
186
4f25082 @levy Allow to run multiple named tests to be run at once.
levy authored
187 (defmethod %run ((tests list))
188 (mapc #'%run tests))
189
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
190 (defmethod %run ((suite test-suite))
191 (let ((suite-results '()))
8e2b8ea @segv Add support for collecting profiling information during test runs.
segv authored
192 (flet ((run-tests ()
193 (loop
194 for test being the hash-values of (tests suite)
195 do (%run test))))
196 (unwind-protect
197 (bind-run-state ((result-list '()))
198 (unwind-protect
199 (if (collect-profiling-info suite)
a3a3f45 @sionescu Drop dependency on Arnesi, use Alexandria instead
authored
200 ;; Timing info doesn't get collected ATM, we need a portable library
201 ;; (setf (profiling-info suite) (collect-timing #'run-tests))
202 (run-tests)
8e2b8ea @segv Add support for collecting profiling information during test runs.
segv authored
203 (run-tests)))
204 (setf suite-results result-list
205 (status suite) (every (lambda (res)
206 (typep res 'test-passed))
207 suite-results)))
208 (with-run-state (result-list)
209 (setf result-list (nconc result-list suite-results)))))))
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
210
211 (defmethod %run ((test-name symbol))
a3a3f45 @sionescu Drop dependency on Arnesi, use Alexandria instead
authored
212 (when-let (test (get-test test-name))
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
213 (%run test)))
214
215 (defvar *initial-!* (lambda () (format t "Haven't run that many tests yet.~%")))
216
217 (defvar *!* *initial-!*)
218 (defvar *!!* *initial-!*)
219 (defvar *!!!* *initial-!*)
220
221 ;;;; ** Public entry points
222
bdbb83c @segv Made run!'s first argument optional (defaults to *suite*)
segv authored
223 (defun run! (&optional (test-spec *suite*))
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
224 "Equivalent to (explain (run TEST-SPEC))."
225 (explain! (run test-spec)))
226
227 (defun explain! (result-list)
228 "Explain the results of RESULT-LIST using a
229 detailed-text-explainer with output going to *test-dribble*"
230 (explain (make-instance 'detailed-text-explainer) result-list *test-dribble*))
231
e358582 @attila-lendvai Added debug! which is run! but enters the debugger on errors
attila-lendvai authored
232 (defun debug! (&optional (test-spec *suite*))
233 "Calls (run! test-spec) but enters the debugger if any kind of error happens."
234 (let ((*debug-on-error* t)
235 (*debug-on-failure* t))
236 (run! test-spec)))
237
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
238 (defun run (test-spec)
eae5025 @levy Add new restart called explain which ignores the rest of the tests and e...
levy authored
239 "Run the test specified by TEST-SPEC.
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
240
241 TEST-SPEC can be either a symbol naming a test or test suite, or
242 a testable-object object. This function changes the operations
243 performed by the !, !! and !!! functions."
eae5025 @levy Add new restart called explain which ignores the rest of the tests and e...
levy authored
244 (psetf *!* (lambda ()
38ea1db @sionescu Use keywords with LOOP
authored
245 (loop :for test :being :the :hash-keys :of *test*
246 :do (setf (status (get-test test)) :unknown))
eae5025 @levy Add new restart called explain which ignores the rest of the tests and e...
levy authored
247 (bind-run-state ((result-list '()))
248 (with-simple-restart (explain "Ignore the rest of the tests and explain current results")
249 (%run test-spec))
250 result-list))
251 *!!* *!*
252 *!!!* *!!*)
253 (funcall *!*))
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
254
1b24abf @sionescu Fix indentation, whitespace
authored
255 (defun ! ()
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
256 "Rerun the most recently run test and explain the results."
257 (explain! (funcall *!*)))
258
1b24abf @sionescu Fix indentation, whitespace
authored
259 (defun !! ()
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
260 "Rerun the second most recently run test and explain the results."
261 (explain! (funcall *!!*)))
1b24abf @sionescu Fix indentation, whitespace
authored
262
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
263 (defun !!! ()
264 "Rerun the third most recently run test and explain the results."
265 (explain! (funcall *!!!*)))
266
267 ;; Copyright (c) 2002-2003, Edward Marco Baringer
1b24abf @sionescu Fix indentation, whitespace
authored
268 ;; All rights reserved.
269 ;;
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
270 ;; Redistribution and use in source and binary forms, with or without
271 ;; modification, are permitted provided that the following conditions are
272 ;; met:
1b24abf @sionescu Fix indentation, whitespace
authored
273 ;;
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
274 ;; - Redistributions of source code must retain the above copyright
275 ;; notice, this list of conditions and the following disclaimer.
1b24abf @sionescu Fix indentation, whitespace
authored
276 ;;
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
277 ;; - Redistributions in binary form must reproduce the above copyright
278 ;; notice, this list of conditions and the following disclaimer in the
279 ;; documentation and/or other materials provided with the distribution.
280 ;;
281 ;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
282 ;; of its contributors may be used to endorse or promote products
283 ;; derived from this software without specific prior written permission.
1b24abf @sionescu Fix indentation, whitespace
authored
284 ;;
1454981 @segv Initial import of FiveAM code. This is exactly equal to to bese-2004@com...
segv authored
285 ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
286 ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
287 ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
288 ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
289 ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
290 ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
291 ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
292 ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
293 ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
294 ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
295 ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Something went wrong with that request. Please try again.