3 (in-package :it.bese.FiveAM)
7 ;;;; At the lowest level testing the system requires that certain
8 ;;;; forms be evaluated and that certain post conditions are met: the
9 ;;;; value returned must satisfy a certain predicate, the form must
10 ;;;; (or must not) signal a certain condition, etc. In FiveAM these
11 ;;;; low level operations are called 'checks' and are defined using
12 ;;;; the various checking macros.
14 ;;;; Checks are the basic operators for collecting results. Tests and
15 ;;;; test suites on the other hand allow grouping multiple checks into
16 ;;;; logic collections.
18 (defvar *test-dribble* t)
20 (defmacro with-*test-dribble* (stream &body body)
21 `(let ((*test-dribble* ,stream))
22 (declare (special *test-dribble*))
25 (eval-when (:compile-toplevel :load-toplevel :execute)
26 (def-special-environment run-state ()
30 ;;;; ** Types of test results
32 ;;;; Every check produces a result object.
34 (defclass test-result ()
35 ((reason :accessor reason :initarg :reason :initform "no reason given")
36 (test-case :accessor test-case :initarg :test-case)
37 (test-expr :accessor test-expr :initarg :test-expr))
38 (:documentation "All checking macros will generate an object of
41 (defclass test-passed (test-result)
43 (:documentation "Class for successful checks."))
45 (defgeneric test-passed-p (object)
47 (:method ((o test-passed)) t))
49 (define-condition check-failure (error)
50 ((reason :accessor reason :initarg :reason :initform "no reason given")
51 (test-case :accessor test-case :initarg :test-case)
52 (test-expr :accessor test-expr :initarg :test-expr))
53 (:documentation "Signaled when a check fails.")
54 (:report (lambda (c stream)
55 (format stream "The following check failed: ~S~%~A."
59 (defmacro process-failure (&rest args)
61 (with-simple-restart (ignore-failure "Continue the test run.")
62 (error 'check-failure ,@args))
63 (add-result 'test-failure ,@args)))
65 (defclass test-failure (test-result)
67 (:documentation "Class for unsuccessful checks."))
69 (defgeneric test-failure-p (object)
71 (:method ((o test-failure)) t))
73 (defclass unexpected-test-failure (test-failure)
74 ((actual-condition :accessor actual-condition :initarg :condition))
75 (:documentation "Represents the result of a test which neither
76 passed nor failed, but signaled an error we couldn't deal
79 Note: This is very different than a SIGNALS check which instead
80 creates a TEST-PASSED or TEST-FAILURE object."))
82 (defclass test-skipped (test-result)
84 (:documentation "A test which was not run. Usually this is due
85 to unsatisfied dependencies, but users can decide to skip test
88 (defgeneric test-skipped-p (object)
90 (:method ((o test-skipped)) t))
92 (defun add-result (result-type &rest make-instance-args)
93 "Create a TEST-RESULT object of type RESULT-TYPE passing it the
94 initialize args MAKE-INSTANCE-ARGS and adds the resulting
95 object to the list of test results."
96 (with-run-state (result-list current-test)
97 (let ((result (apply #'make-instance result-type
98 (append make-instance-args (list :test-case current-test)))))
100 (test-passed (format *test-dribble* "."))
101 (unexpected-test-failure (format *test-dribble* "X"))
102 (test-failure (format *test-dribble* "f"))
103 (test-skipped (format *test-dribble* "s")))
104 (push result result-list))))
106 ;;;; ** The check operators
108 ;;;; *** The IS check
110 (defmacro is (test &rest reason-args)
111 "The DWIM checking operator.
113 If TEST returns a true value a test-passed result is generated,
114 otherwise a test-failure result is generated and the reason,
115 unless REASON-ARGS is provided, is generated based on the form of
118 (predicate expected actual) - Means that we want to check
119 whether, according to PREDICATE, the ACTUAL value is
120 in fact what we EXPECTED.
122 (predicate value) - Means that we want to ensure that VALUE
125 Wrapping the TEST form in a NOT simply preducse a negated reason string."
128 "Argument to IS must be a list, not ~S" test)
129 (let (bindings effective-test default-reason-args)
130 (with-unique-names (e a v)
131 (list-match-case test
132 ((not (?predicate ?expected ?actual))
133 (setf bindings (list (list e ?expected)
135 effective-test `(not (,?predicate ,e ,a))
136 default-reason-args (list "~S was ~S to ~S" a `',?predicate e)))
137 ((not (?satisfies ?value))
138 (setf bindings (list (list v ?value))
139 effective-test `(not (,?satisfies ,v))
140 default-reason-args (list "~S satisfied ~S" v `',?satisfies)))
141 ((?predicate ?expected ?actual)
142 (setf bindings (list (list e ?expected)
144 effective-test `(,?predicate ,e ,a)
145 default-reason-args (list "~S was not ~S to ~S" a `',?predicate e)))
147 (setf bindings (list (list v ?value))
148 effective-test `(,?satisfies ,v)
149 default-reason-args (list "~S did not satisfy ~S" v `',?satisfies)))
153 default-reason-args (list "No reason supplied"))))
156 (add-result 'test-passed :test-expr ',test)
157 (process-failure :reason (format nil ,@(or reason-args default-reason-args))
158 :test-expr ',test))))))
160 ;;;; *** Other checks
162 (defmacro skip (&rest reason)
163 "Generates a TEST-SKIPPED result."
165 (format *test-dribble* "s")
166 (add-result 'test-skipped :reason (format nil ,@reason))))
168 (defmacro is-equal (&rest args)
169 "Generates (is (equal (multiple-value-list ,expr) (multiple-value-list ,value))) for each pair of elements.
170 If the value is a (values a b * d *) form then the elements at * are not compared."
171 (with-unique-names (expr-result)
173 ,@(loop for (expr value) on args by #'cddr
174 do (assert (and expr value))
175 if (and (consp value)
176 (eq (car value) 'values))
177 collect `(let ((,expr-result (multiple-value-list ,expr)))
178 ,@(loop for cell = (rest (copy-list value)) then (cdr cell)
181 when (eq (car cell) '*)
182 collect `(setf (elt ,expr-result ,i) nil)
183 and do (setf (car cell) nil))
184 (is (equal ,expr-result (multiple-value-list ,value))))
185 else collect `(is (equal ,expr ,value))))))
187 (defmacro is-string= (&rest args)
188 "Generates (is (string= ,expr ,value)) for each pair of elements."
190 ,@(loop for (expr value) on args by #'cddr
191 do (assert (and expr value))
192 collect `(is (string= ,expr ,value)))))
194 (defmacro is-true (condition &rest reason-args)
195 "Like IS this check generates a pass if CONDITION returns true
196 and a failure if CONDITION returns false. Unlike IS this check
197 does not inspect CONDITION to determine how to report the
200 (add-result 'test-passed :test-expr ',condition)
202 :reason ,(if reason-args
203 `(format nil ,@reason-args)
204 `(format nil "~S did not return a true value" ',condition))
205 :test-expr ',condition)))
207 (defmacro is-false (condition &rest reason-args)
208 "Generates a pass if CONDITION returns false, generates a
209 failure otherwise. Like IS-TRUE, and unlike IS, IS-FALSE does
210 not inspect CONDITION to determine what reason to give it case
214 :reason ,(if reason-args
215 `(format nil ,@reason-args)
216 `(format nil "~S returned a true value" ',condition))
217 :test-expr ',condition)
218 (add-result 'test-passed :test-expr ',condition)))
220 (defmacro signals (condition-spec
222 "Generates a pass if BODY signals a condition of type
223 CONDITION. BODY is evaluated in a block named NIL, CONDITION is
225 (let ((block-name (gensym)))
226 (destructuring-bind (condition &optional reason-control reason-args)
227 (ensure-list condition-spec)
229 (handler-bind ((,condition (lambda (c)
231 ;; ok, body threw condition
232 (add-result 'test-passed
233 :test-expr ',condition)
234 (return-from ,block-name t))))
238 :reason ,(if reason-control
239 `(format nil ,reason-control ,@reason-args)
240 `(format nil "Failed to signal a ~S" ',condition))
241 :test-expr ',condition)
242 (return-from ,block-name nil)))))
244 (defmacro finishes (&body body)
245 "Generates a pass if BODY executes to normal completion. In
246 other words if body does signal, return-from or throw this test
254 (add-result 'test-passed :test-expr ',body)
256 :reason (format nil "Test didn't finish")
257 :test-expr ',body)))))
259 (defmacro pass (&rest message-args)
260 "Simply generate a PASS."
261 `(add-result 'test-passed
262 :test-expr ',message-args
264 `(:reason (format nil ,@message-args)))))
266 (defmacro fail (&rest message-args)
267 "Simply generate a FAIL."
269 :test-expr ',message-args
271 `(:reason (format nil ,@message-args)))))
273 ;; Copyright (c) 2002-2003, Edward Marco Baringer
274 ;; All rights reserved.
276 ;; Redistribution and use in source and binary forms, with or without
277 ;; modification, are permitted provided that the following conditions are
280 ;; - Redistributions of source code must retain the above copyright
281 ;; notice, this list of conditions and the following disclaimer.
283 ;; - Redistributions in binary form must reproduce the above copyright
284 ;; notice, this list of conditions and the following disclaimer in the
285 ;; documentation and/or other materials provided with the distribution.
287 ;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
288 ;; of its contributors may be used to endorse or promote products
289 ;; derived from this software without specific prior written permission.
291 ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
292 ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
293 ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
294 ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
295 ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
296 ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
297 ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
298 ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
299 ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
300 ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
301 ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE