1 ;;;-*- Mode: Lisp; Package: LIFT -*-
5 See file COPYING for license
9 (defpackage #:lift-test
10 (:use
#:common-lisp
#:lift
)
18 #:testsuite-test-count
19 #:*test-environment
*))
20 (in-package #:lift-test
)
22 (deftestsuite lift-test
() ())
24 ;;; ---------------------------------------------------------------------------
26 ;;; make sure that ensure and its friends work as expected
28 ;;; The strategy here is to pair "regular" tests with meta-tests. The
29 ;;; regular tests are normal tests written using LIFT. The meta-tests
30 ;;; use run-tests or run-tests to run the regular test and then grovel
31 ;;; over the returned test-result to make sure it contains what it is
33 ;;; ---------------------------------------------------------------------------
35 (deftestsuite lift-test-ensure
(lift-test) ())
36 (deftestsuite lift-test-ensure-helper
() ())
38 (addtest (lift-test-ensure-helper)
42 (addtest (lift-test-ensure)
44 (let ((tr (run-test :suite
'lift-test-ensure-helper
45 :name
'simple-ensure-test-1
)))
46 (ensure-same (length (tests-run tr
)) 1)
47 (ensure-null (failures tr
))
48 (ensure-null (errors tr
))
49 (ensure-same (test-mode tr
) :single
)
50 (ensure-same (mapcar #'second
(tests-run tr
))
51 '(lift-test::simple-ensure-test-1
))))
53 ;;; ---------------------------------------------------------------------------
55 (addtest (lift-test-ensure-helper)
59 (addtest (lift-test-ensure)
61 (let ((tr (run-test :suite
'lift-test-ensure-helper
62 :name
'simple-ensure-test-2
)))
63 (ensure-same (length (tests-run tr
)) 1 :report
"Number of tests-run")
64 (ensure-same (length (failures tr
)) 1 :report
"Number of failures")
65 (ensure-null (errors tr
) :report
"Number of errors")
66 (ensure-same (mapcar #'second
(tests-run tr
))
67 '(lift-test::simple-ensure-test-2
))))
69 ;;; ---------------------------------------------------------------------------
71 (addtest (lift-test-ensure-helper)
73 (ensure (let ((x 0)) (/ x
))))
75 (addtest (lift-test-ensure)
77 (let ((tr (run-test :suite
'lift-test-ensure-helper
78 :name
'simple-ensure-test-3
)))
79 (ensure-same (length (tests-run tr
)) 1)
80 (ensure-same (length (failures tr
)) 0)
81 (ensure-same (length (errors tr
)) 1)
82 (ensure-same (mapcar #'second
(tests-run tr
))
83 '(lift-test::simple-ensure-test-3
))))
86 ;;; ---------------------------------------------------------------------------
87 ;;; lift-test-setup-teardown
88 ;;; make sure that setup and teardown happen in the right order
89 ;;; ---------------------------------------------------------------------------
91 (deftestsuite lift-test-setup-teardown
(lift-test) ())
93 (deftestsuite lift-test-setup-teardown-1
(lift-test-setup-teardown) ()
94 (:setup
(push 1 *test-notepad
*))
95 (:teardown
(push :a
*test-notepad
*))
96 (:tests
(setup-teardown-1 (push 'test-1
*test-notepad
*))))
98 (addtest (lift-test-setup-teardown)
100 (setf *test-notepad
* nil
)
102 :name
'setup-teardown-1
103 :suite
'lift-test-setup-teardown-1
104 :result
(make-test-result 'lift-test-setup-teardown-1
:single
))
105 (ensure-same (reverse *test-notepad
*)
108 (addtest (lift-test-setup-teardown)
110 (setf *test-notepad
* nil
)
112 :suite
'lift-test-setup-teardown-1
113 :result
(make-test-result 'lift-test-setup-teardown-1
:multiple
))
114 (ensure-same (reverse *test-notepad
*)
115 '(1 test-1
:a
1 2 test-2
:b
:a
1 2 3 test-3
:c
:b
:a
)))
117 (deftestsuite lift-test-setup-teardown-2
(lift-test-setup-teardown-1) ()
118 (:setup
(push 2 *test-notepad
*))
119 (:teardown
(push :b
*test-notepad
*))
120 (:tests
(setup-teardown-2 (push 'test-2
*test-notepad
*))))
122 (deftestsuite lift-test-setup-teardown-3
(lift-test-setup-teardown-2) ()
123 (:setup
(push 3 *test-notepad
*))
124 (:teardown
(push :c
*test-notepad
*))
125 (:tests
(setup-teardown-3 (push 'test-3
*test-notepad
*))))
127 (addtest (lift-test-setup-teardown)
129 (setf *test-notepad
* nil
)
131 :name
'setup-teardown-3
132 :suite
'lift-test-setup-teardown-3
133 :result
(make-test-result 'lift-test-setup-teardown-3
:single
))
134 (ensure-same (reverse *test-notepad
*)
135 '(1 2 3 test-3
:c
:b
:a
)))
137 (addtest (lift-test-setup-teardown)
139 (setf *test-notepad
* nil
)
141 :suite
'lift-test-setup-teardown-3
142 :result
(make-test-result 'lift-test-setup-teardown-3
:multiple
))
143 (ensure-same (reverse *test-notepad
*)
144 '(1 2 3 test-3
:c
:b
:a
)))
146 ;;; ---------------------------------------------------------------------------
148 ;;; ---------------------------------------------------------------------------
150 (deftestsuite lift-test-ensure-same
(lift-test)
153 ;;?? Gary King 2004-06-21: not really a test yet, more of a syntax works check
154 (addtest (lift-test-ensure-same)
155 (ensure-same 2 2 :test
=)
156 (ensure-same 2 2 :test
'=)
157 (ensure-same 2 2 :test
#'=))
159 ;;; ---------------------------------------------------------------------------
160 ;;; test single setup
161 ;;; ---------------------------------------------------------------------------
163 (deftestsuite test-single-setup
(lift-test) ())
166 (deftestsuite test-single-setup-helper
() ())
168 (deftestsuite test-single-setup-child-a
(test-single-setup-helper) ()
169 (:setup
(push :a
*test-notepad
*))
170 (:test
(test-1 (ensure t
))))
172 (deftestsuite test-single-setup-child-a-1
(test-single-setup-child-a) ()
173 (:setup
(push :a-1
*test-notepad
*))
174 (:test
(test-1 (ensure t
)))
175 (:test
(test-2 (ensure t
))))
177 (deftestsuite test-single-setup-child-b
(test-single-setup-helper) ()
178 (:setup
(push :b
*test-notepad
*))
179 (:test
(test-1 (ensure t
))))
181 (deftestsuite test-single-setup-child-b-1-ss
(test-single-setup-child-b) ()
182 (:run-setup
:once-per-suite
)
183 (:setup
(push :b-1
*test-notepad
*))
184 (:test
(test-1 (ensure t
)))
185 (:test
(test-2 (ensure t
))))
187 (deftestsuite test-single-setup-child-b-1-a
(test-single-setup-child-b-1-ss) ()
188 (:setup
(push :b-1-a
*test-notepad
*))
189 (:test
(test-1 (ensure t
)))
190 (:test
(test-2 (ensure t
))))
192 (deftestsuite test-single-setup-child-b-1-b
(test-single-setup-child-b-1-ss) ()
193 (:setup
(push :b-1-b
*test-notepad
*))
194 (:test
(test-1 (ensure t
)))
195 (:test
(test-2 (ensure t
))))
197 (deftestsuite test-single-setup-child-c
(test-single-setup-helper) ()
198 (:setup
(push :c
*test-notepad
*))
199 (:test
(test-1 (ensure t
))))
201 (deftestsuite test-single-setup-child-c-1
(test-single-setup-child-c) ()
202 (:setup
(push :c-1
*test-notepad
*))
203 (:test
(test-1 (ensure t
))))
205 ;;; ---------------------------------------------------------------------------
207 (addtest (test-single-setup)
208 test-a-multiple-setup
209 (setf *test-notepad
* nil
)
210 (run-test :suite
'test-single-setup-child-a-1
:name
'test-1
)
211 (run-test :suite
'test-single-setup-child-a-1
:name
'test-2
)
212 (ensure-same *test-notepad
* '(:a-1
:a
:a-1
:a
)))
214 (addtest (test-single-setup)
215 test-b-single-setup-1
216 (setf *test-notepad
* nil
)
217 (run-test :suite
'test-single-setup-child-b-1-ss
:name
'test-1
)
218 (run-test :suite
'test-single-setup-child-b-1-ss
:name
'test-2
)
219 ;; single tests do all the setup so this should be exactly the same
220 (ensure-same *test-notepad
* '(:b-1
:b
:b-1
:b
)))
222 (addtest (test-single-setup)
223 test-a-single-setup-2
224 (setf *test-notepad
* nil
)
225 (run-tests :suite
'test-single-setup-child-a-1
:do-children? nil
)
226 (ensure-same *test-notepad
* '(:a-1
:a
:a-1
:a
)))
228 (addtest (test-single-setup)
229 test-a-single-setup-3
230 (setf *test-notepad
* nil
)
231 (run-tests :suite
'test-single-setup-child-a-1
232 :run-setup
:once-per-suite
234 (ensure-same *test-notepad
* '(:a-1
:a
:a-1
:a
)))
236 (addtest (test-single-setup)
237 test-b-single-setup-2
238 (setf *test-notepad
* nil
)
239 (run-tests :suite
'test-single-setup-child-b-1-ss
:do-children? nil
)
240 (ensure-same *test-notepad
* '(:b-1
:b
)))
242 ;;; ---------------------------------------------------------------------------
244 ;;; ---------------------------------------------------------------------------
246 (deftestsuite test-ignore-warnings
(lift-test) ())
248 (deftestsuite test-ignore-warnings-helper
() ())
250 (deftestsuite test-ignore-warnings-helper-warning
(test-ignore-warnings-helper) ()
252 (push :a
*test-scratchpad
*)
254 (push :b
*test-scratchpad
*))))
256 (deftestsuite test-ignore-warnings-helper-no-warning
(test-ignore-warnings-helper) ()
258 (push :a
*test-scratchpad
*)
260 (push :b
*test-scratchpad
*))))
262 (addtest (test-ignore-warnings)
264 (run-test :suite
'test-ignore-warnings-helper-warning
:name
'do-it
)
265 (ensure-same *test-scratchpad
* '(:b
:a
)))
267 (addtest (test-ignore-warnings)
269 (run-test :suite
'test-ignore-warnings-helper-no-warning
:name
'do-it
)
270 (ensure-same *test-scratchpad
* '(:b
:a
)))
272 ;;; ---------------------------------------------------------------------------
273 ;;; test-environment stays clean
274 ;;; ---------------------------------------------------------------------------
276 (deftestsuite lift-test-environment-pristine
(lift-test) ()
277 (:setup
(setf *test-environment
* nil
)))
279 (deftestsuite lift-test-environment-pristine-helper
()
283 (addtest (lift-test-environment-pristine-helper)
285 (ensure-same (* a a
) b
))
287 (addtest (lift-test-environment-pristine
288 :expected-failure
"This is no longer guarenteed; I'm not sure yet whether or not this is a good thing.")
290 (run-test :suite
'lift-test-environment-pristine-helper
:name
'do-it
)
291 (ensure (null *test-environment
*)))
294 ;;; ---------------------------------------------------------------------------
295 ;;; test-creating-multiple-tests
296 ;;; ---------------------------------------------------------------------------
298 (deftestsuite test-creating-multiple-tests
(lift-test)
301 (deftestsuite test-creating-multiple-tests-helper
()
303 (:tests
((ensure-same 1 1)
305 ((ensure-same 3 3))))
307 (addtest (test-creating-multiple-tests)
309 (ensure-same (testsuite-test-count 'test-creating-multiple-tests-helper
) 2))
313 (defvar *dynamics-before-setup
* :dbs
)
315 (deftestsuite dynamics-before-setup
(lift-test)
317 :setup
(setf *test-notepad
* nil
))
319 (deftestsuite dynamics-before-setup-helper
()
320 ((slot (progn (push :slot
*test-notepad
*) :slot
)))
321 :dynamic-variables
(*dynamics-before-setup
*
322 (progn (push :dynamics
*test-notepad
*) :dynamics
))
323 :setup
(push :setup
*test-notepad
*))
325 (addtest (dynamics-before-setup-helper)
327 (push :test
*test-notepad
*)
328 (ensure-same *dynamics-before-setup
* :dynamics
))
330 (addtest (dynamics-before-setup)
332 (run-test :suite
'dynamics-before-setup-helper
334 (ensure-same (reverse *test-notepad
*)
335 '(:dynamics
:slot
:setup
:test
)))
339 ;;; inherited functions
341 (deftestsuite test-inherited-functions-helper
()
345 (ensure-same (+ a b
) c
:test
'=))))
347 (deftestsuite test-inherited-functions-pos
(test-inherited-functions-helper)
349 (:tests
((really?
1 2 3))
352 (deftestsuite test-inherited-functions-neg
(test-inherited-functions-helper)
354 (:tests
((really? -
4 -
2 -
6))
355 ((really? -
1 -
1 -
2))))
357 (deftestsuite test-inherited-functions
(lift-test)
360 (addtest (test-inherited-functions)
362 (let ((tr (run-tests :suite
'test-inherited-functions-helper
)))
363 (ensure-same (length (tests-run tr
)) 4)
364 (ensure-null (failures tr
))
365 (ensure-null (errors tr
))))
369 ;;; slot initialization takes place with every setup
371 (deftestsuite test-initialize-slots-helper
()
372 ((slot (incf *test-notepad
*))))
374 (addtest (test-initialize-slots-helper)
378 (addtest (test-initialize-slots-helper)
382 (deftestsuite test-initialize-slots
(lift-test)
384 (:setup
(setf *test-notepad
* 0)))
386 (addtest (test-initialize-slots)
387 slot-initform-evaluated-every-time
388 (let ((tr (run-tests :suite
'test-initialize-slots-helper
)))
389 (ensure-same (length (tests-run tr
)) 2)
390 (ensure-same *test-notepad
* 2 :test
'=)))