1 (in-package #:lift-test
)
3 (deftestsuite test-a
()
7 (defmethod initialize-prototypes :after
((test test-plus
))
9 (setf (prototypes test
)
16 (defmethod initialize-prototypes :after
((test test-plus
))
17 (with-test-slots (a b
)
18 (setf (prototypes test
)
25 (defmethod initialize-prototypes :after
((test test-plus
))
26 (with-test-slots (a b
)
27 (setf (prototypes test
)
30 (list (cons 'a a
) (cons 'b b
)))))))
32 (deftestsuite test-a
()
35 (deftestsuite test-a
()
37 (:cases
(a '((1 2)))))
42 (deftestsuite test-b
(test-a)
44 (:cases
(b '(4 5 6))))
47 (format t
"~% ~A x ~A" a b
))
50 (deftestsuite test-e
()
53 (defmethod initialize-prototypes :after
((test test-e
))
54 (setf (prototypes test
)
62 (deftestsuite test-f
(test-e)
65 (defmethod initialize-prototypes :after
((test test-f
))
66 (setf (prototypes test
)
73 (format t
"~% ~A x ~A" a b
))
85 (defgeneric setup
(suite)
86 (:documentation
"Setup at the testsuite-level")
87 (:method
((suite test-mixin
))
90 (defgeneric testsuite-teardown
(suite)
91 (:documentation
"Cleanup at the testsuite level.")
92 (:method
((suite test-mixin
))
95 (defgeneric testsuite-run
(suite result
)
96 (:documentation
"Run the cases in this suite and it's children."))
98 (defgeneric setup-test
(test-case)
99 (:documentation
"Setup for a test-case. By default it does nothing."))
101 (defgeneric teardown-test
(test-case)
102 (:documentation
"Tear-down a test-case. By default it does nothing.")
103 (:method-combination progn
:most-specific-first
))
105 (defgeneric testsuite-methods
(test-case)
106 (:documentation
"Returns a list of the test methods defined for test. I.e.,
107 the methods that should be run to do the tests for this test."))
111 (deftestsuite setup-and-slots-hierarchy-parent
()
112 ((slot-parent (progn (push :slot-parent
*test-scratchpad
*) :a
)))
113 :setup
(push :setup-parent
*test-scratchpad
*)
114 :teardown
(push :teardown-parent
*test-scratchpad
*))
116 (deftestsuite setups-and-slots-hierarchy-child
117 (setup-and-slots-hierarchy-parent)
118 ((slot-child (progn (push :slot-child
*test-scratchpad
*) :a
)))
119 :setup
(push :setup-child
*test-scratchpad
*)
120 :teardown
(push :teardown-child
*test-scratchpad
*))
124 ;;;;;;;;;;;;;;;;;;;;;
128 (defvar *dynamics-before-setup
* :dbs
)
130 (deftestsuite dynamics-before-setup
()
132 :setup
(setf *test-notepad
* nil
))
134 (deftestsuite dynamics-before-setup-helper
()
135 ((slot (progn (push :slot
*test-notepad
*) :slot
)))
136 :dynamic-variables
(*dynamics-before-setup
*
137 (progn (push :dynamics
*test-notepad
*) :dynamics
))
138 :setup
(push :setup
*test-notepad
*))
140 (addtest (dynamics-before-setup-helper)
142 (push :test
*test-notepad
*)
143 (ensure-same *dynamics-before-setup
* :dynamics
))
145 (addtest (dynamics-before-setup)
147 (run-test :suite
'dynamics-before-setup-helper
149 (ensure-same (reverse *test-notepad
*)
150 '(:dynamics
:slot
:setup
:test
)))
152 (run-test :break-on-errors? t
)
158 (deftestsuite warnings-and-errors
()
161 (defun warnings-and-errors-function (mode)
163 (:warn
(warn "this is a warning all by itself"))
164 (:error
(error "this is an error all by itself"))
165 (:warn-error
(warn "first we warn") (error "then we error"))
166 (:error-warn
(error "first we error") (warn "then we warn"))))
168 (addtest (warnings-and-errors)
169 warning-does-not-hide-error-1
170 (ensure-error (warnings-and-errors-function :warn-error
)))
172 (addtest (warnings-and-errors)
173 warning-does-not-hide-error-2
174 (ensure-warning (warnings-and-errors-function :warn-error
)))