1 ;;;-*- Mode: Lisp; Package: lift -*-
5 (defmethod accumulate-problem ((problem test-failure-mixin
) result
)
6 (setf (failures result
) (append (failures result
) (list problem
))))
8 (defmethod accumulate-problem ((problem testsuite-failure
) result
)
9 (setf (failures result
) (append (failures result
) (list problem
))))
11 (defmethod accumulate-problem ((problem test-expected-failure
) result
)
12 (setf (expected-failures result
)
13 (append (expected-failures result
) (list problem
))))
15 (defmethod accumulate-problem ((problem test-error-mixin
) result
)
16 (setf (errors result
) (append (errors result
) (list problem
))))
18 (defmethod accumulate-problem ((problem testsuite-error
) result
)
19 (setf (errors result
) (append (errors result
) (list problem
))))
21 (defmethod accumulate-problem ((problem test-serious-condition
) result
)
22 (setf (errors result
) (append (errors result
) (list problem
))))
24 (defmethod accumulate-problem ((problem testsuite-serious-condition
) result
)
25 (setf (errors result
) (append (errors result
) (list problem
))))
27 (defmethod accumulate-problem ((problem test-expected-error
) result
)
28 (setf (expected-errors result
)
29 (append (expected-errors result
) (list problem
))))
31 (defmethod accumulate-problem ((problem testcase-skipped
) result
)
32 (setf (skipped-test-cases result
)
33 (append (skipped-test-cases result
) (list problem
))))
35 (defmethod accumulate-problem ((problem testsuite-skipped
) result
)
36 (setf (skipped-testsuites result
)
37 (append (skipped-testsuites result
) (list problem
))))
40 ;;; ---------------------------------------------------------------------------
42 ;;; ---------------------------------------------------------------------------
44 (defcondition (lift-compile-error :exportp nil
) (error)
46 "Compile error: '~S'" msg
)
48 (defcondition testsuite-not-defined
(lift-compile-error)
50 "Test class ~A not defined before it was used."
53 (defcondition testsuite-ambiguous
(lift-compile-error)
54 (testsuite-name possible-matches
)
55 "There are several test suites named ~s: they are ~{~s~^, ~}"
56 testsuite-name possible-matches
)
58 (defcondition test-case-not-defined
(lift-compile-error)
59 (testsuite-name test-case-name
)
60 "Testsuite ~s has no test-case named ~s."
61 testsuite-name test-case-name
)
63 (defcondition test-case-ambiguous
(lift-compile-error)
64 (testsuite-name test-case-name possible-matches
)
65 "There are several test cases named ~s.~s: they are ~{~s~^, ~}"
66 testsuite-name test-case-name possible-matches
)
68 (defcondition test-condition
(warning)
69 ((message :initform
""))
72 (defcondition (test-timeout-condition :slot-names
(message)) (test-condition)
73 ((maximum-time :initform
*test-maximum-time
*))
74 "Test ran out of time (longer than ~S-second~:P)"
77 (defcondition (ensure-failed-error :slot-names
(message)) (test-condition)
78 ((assertion :initform
""))
79 "Ensure failed: ~S ~@[(~a)~]" assertion message
)
81 (defcondition (ensure-null-failed-error :slot-names
(message)) (ensure-failed-error)
83 (assertion :initform
""))
84 "Ensure null failed: ~s evaluates to ~s ~@[(~a)~]"
85 assertion value message
)
87 (defcondition ensure-expected-condition
(test-condition)
88 ((expected-condition-type
92 "Expected ~S but got ~S~@[:~_ ~A~]"
93 expected-condition-type
94 (type-of the-condition
)
95 (and (typep the-condition
'condition
)
98 (defcondition ensure-expected-no-warning-condition
(test-condition)
101 "Expected no warnings but got ~S"
104 (defcondition failed-comparison-condition
(test-condition)
105 (first-value second-value test
))
107 (defcondition (ensure-not-same :slot-names
(first-value second-value test message
))
108 (failed-comparison-condition)
110 "Ensure-same: ~S is not ~a to ~S~@[ (~a)~]"
111 first-value
(test-function-name test
)
112 second-value message
)
114 (defcondition (ensure-same :slot-names
(first-value second-value test message
))
115 (failed-comparison-condition)
117 "Ensure-different: ~S is ~a to ~S~@[ (~a)~]"
118 first-value
(test-function-name test
) second-value message
)
120 (defcondition ensure-cases-failure
(test-condition)
122 (problems :initform nil
)
123 (errors :initform nil
))
126 "Ensure-cases: ~d case~:p with ~[~:;~:*~d error~:p; ~]~[~:;~:*~d failure~:p; ~]"
127 total
(length errors
) (length problems
))
129 (format stream
"~&Errors: ~@< ~@;~{~% ~{~20s ~3,8@t~a~}~^, ~}~:>"
132 (format stream
"~&Failures: ~@< ~@;~{~% ~{~20s ~3,8@t~a~}~^, ~}~:>"
135 (defcondition unexpected-success-failure
(test-condition)
136 (expected expected-more
)
137 "Test succeeded but we expected ~s (~s)"
138 expected expected-more
)
140 (defun build-lift-error-message (context message
&rest arguments
)
143 (apply #'format nil message arguments
)))
145 (defun signal-lift-error (context message
&rest arguments
)
146 (let ((c (make-condition
148 :msg
(apply #'build-lift-error-message
149 context message arguments
))))
153 (defun report-lift-error (context message
&rest arguments
)
154 (format *debug-io
* "~&~A."
155 (apply #'build-lift-error-message context message arguments
))
158 (defun lift-report-condition (c)
159 (format *debug-io
* "~&~A." c
))
161 (defun %build-ensure-comparison
162 (form values guard-fn test test-specified-p report arguments
163 ignore-multiple-values?
)
164 (setf test
(remove-leading-quote test
))
165 (when (and (consp test
)
166 (eq (first test
) 'function
))
167 (setf test
(second test
)))
168 (let ((gblock (gensym "block-"))
171 (gtest (gensym "test-")))
173 (flet ((,gtest
(,ga
,gb
)
174 (,@(cond (test-specified-p
179 `(funcall *lift-equality-test
*)))
181 (loop for value in
(,(if ignore-multiple-values?
182 'list
'multiple-value-list
) ,form
)
183 for other-value in
(,(if ignore-multiple-values?
184 'list
'multiple-value-list
) ,values
) do
185 (,guard-fn
(,gtest value other-value
)
187 (unless 'maybe-raise-not-same-condition
)
188 (when 'maybe-raise-ensure-same-condition
))
190 ,(if test-specified-p
(list 'quote test
) '*lift-equality-test
*)
192 (return-from ,gblock nil
))))
195 (defun maybe-raise-not-same-condition (value-1 value-2 test
196 report
&rest arguments
)
197 (let ((condition (make-condition 'ensure-not-same
199 :second-value value-2
201 :message
(when report
203 report arguments
)))))
204 (if (find-restart 'ensure-failed
)
205 (invoke-restart 'ensure-failed condition
)
208 (defun maybe-raise-ensure-same-condition (value-1 value-2 test
209 report
&rest arguments
)
210 (let ((condition (make-condition 'ensure-same
212 :second-value value-2
214 :message
(when report
216 report arguments
)))))
217 (if (find-restart 'ensure-failed
)
218 (invoke-restart 'ensure-failed condition
)
222 ;;; ---------------------------------------------------------------------------
224 ;;; ---------------------------------------------------------------------------
226 (defmethod testsuite-setup ((testsuite test-mixin
) (result test-result
))
229 (defmethod testsuite-setup :before
((testsuite test-mixin
) (result test-result
))
230 (push (type-of testsuite
) (suites-run result
))
231 (setf (current-step result
) :testsuite-setup
))
233 (defmethod testsuite-expects-error ((testsuite test-mixin
))
236 (defmethod testsuite-expects-failure ((testsuite test-mixin
))
239 (defmethod testsuite-teardown ((testsuite test-mixin
) (result test-result
))
243 (defmethod testsuite-teardown :after
244 ((testsuite test-mixin
) (result test-result
))
245 (setf (current-step result
) :testsuite-teardown
246 (real-end-time result
) (get-test-real-time)
247 (real-end-time-universal result
) (get-universal-time)))
251 (defun canonize-skip-tests (skip-tests)
254 (cond ((or (atom datum
)
255 (and (= (length datum
) 1)
256 (setf datum
(first datum
)))
257 (and (= (length datum
) 2) (null (second datum
))
258 (setf datum
(first datum
))))
259 (cons (find-testsuite datum
:errorp t
) nil
))
260 ((= (length datum
) 2)
261 (cons (find-testsuite (first datum
) :errorp t
)
262 (or (and (keywordp (second datum
)) (second datum
))
263 (find-test-case (find-testsuite (first datum
))
264 (second datum
) :errorp t
))))
266 (warn "Unable to interpret skip datum ~a. Ignoring."
270 (defun test-result-property (result property
&optional default
)
271 (getf (test-result-properties result
) property default
))
273 (defun (setf test-result-property
) (value result property
)
274 (setf (getf (test-result-properties result
) property
) value
))
276 (defmethod write-profile-information ((suite t
))
279 (defmethod equality-test ((suite test-mixin
))
282 (defmethod setup-test :before
((test test-mixin
))
283 (setf *test-scratchpad
* nil
))
285 (defmethod setup-test ((test test-mixin
))
288 (defmethod setup-test ((test symbol
))
289 (let ((*current-test
* (make-testsuite test nil
)))
290 (setup-test *current-test
*)
293 (defmethod test-case-teardown progn
((test test-mixin
) (result test-result
))
296 (defmethod test-case-teardown :around
((test test-mixin
) (result test-result
))
297 (setf (current-step result
) :test-teardown
)
300 (defmethod initialize-instance :after
((testsuite test-mixin
) &rest initargs
301 &key
&allow-other-keys
)
302 (when (null (testsuite-name testsuite
))
303 (setf (slot-value testsuite
'name
)
304 (symbol-name (type-of testsuite
)))))
306 (defmethod print-object ((tc test-mixin
) stream
)
307 (print-unreadable-object (tc stream
:identity t
:type t
)
308 (format stream
"~a" (testsuite-name tc
))))
310 ;;; ---------------------------------------------------------------------------
312 ;;; ---------------------------------------------------------------------------
314 (defun initialize-current-definition ()
315 (setf *current-definition
* nil
))
317 (defun set-definition (name value
)
318 (let ((current (assoc name
*current-definition
*)))
320 (setf (cdr current
) value
)
321 (push (cons name value
) *current-definition
*)))
325 (defun def (name &optional
(definition *current-definition
*))
326 (when definition
(cdr (assoc name definition
))))
328 (defun (setf def
) (value name
)
329 (set-definition name value
))
331 (defstruct (code-block (:type list
) (:conc-name nil
))
332 block-name
(priority 0) filter code operate-when
)
334 (defun add-code-block (name priority operate-when filter handler code
)
335 (let ((current (assoc name
*code-blocks
*))
336 (value (make-code-block
337 :operate-when operate-when
343 (setf (cdr current
) value
)
344 (push (cons name value
) *code-blocks
*))
346 `(defmethod block-handler ((name (eql ',name
)) value
)
347 (declare (ignorable value
))
349 (setf *code-blocks
* (sort *code-blocks
* #'<
350 :key
(lambda (name.cb
)
351 (priority (cdr name.cb
))))))
353 (defmacro deftest
(testsuite-name superclasses slots
&rest
355 "The `deftest` form is obsolete, see [deftestsuite][]."
357 (warn "Deftest is obsolete, use deftestsuite instead.")
358 `(deftestsuite ,testsuite-name
,superclasses
,slots
,@clauses-and-options
))
360 (setf *code-blocks
* nil
)
365 '((setf (def :setup
) (cleanup-parsed-parameter value
)))
366 'build-setup-test-method
)
369 :teardown
100 :methods
370 (lambda () (or (def :teardown
) (def :direct-slot-names
)))
371 '((setf (def :teardown
) (cleanup-parsed-parameter value
)))
372 'build-test-teardown-method
)
376 (lambda () (def :functions
))
377 '((push value
(def :functions
)))
378 'build-test-local-functions
)
381 :documentation
0 :class-def
383 '((setf (def :documentation
) (first value
)))
387 :export-p
0 :class-def
389 '((setf (def :export-p
) (first value
)))
393 :export-slots
0 :class-def
395 '((setf (def :export-slots
) (first value
)))
399 :run-setup
0 :class-def
401 '((push (first value
) (def :default-initargs
))
402 (push :run-setup
(def :default-initargs
))
403 (setf (def :run-setup
) (first value
)))
404 'check-run-setup-value
)
406 (defun %valid-run-setup-values
()
407 '(:once-per-session
:once-per-suite
408 :once-per-test-case
:never
))
410 (defun check-run-setup-value ()
411 (when (def :run-setup
)
412 (unless (member (def :run-setup
) (%valid-run-setup-values
))
413 (error "The :run-setup option must be one of ~{~a~^, ~}."
414 (%valid-run-setup-values
)))))
417 :equality-test
0 :methods
418 (lambda () (def :equality-test
))
419 '((setf (def :equality-test
) (cleanup-parsed-parameter value
)))
420 'build-test-equality-test
)
423 :expected-error
0 :methods
424 (lambda () (def :expected-error
))
425 '((setf (def :expected-error
) (cleanup-parsed-parameter value
)))
426 'build-testsuite-expected-error
)
429 :expected-failure
0 :methods
430 (lambda () (def :expected-failure
))
431 '((setf (def :expected-failure
) (cleanup-parsed-parameter value
)))
432 'build-testsuite-expected-failure
)
435 :log-file
0 :class-def
437 '((push (first value
) (def :default-initargs
))
438 (push :log-file
(def :default-initargs
)))
442 :dynamic-variables
0 :class-def
444 '((setf (def :direct-dynamic-variables
) value
))
448 :categories
0 :class-def
450 '((push value
(def :categories
)))
454 :default-initargs
1 :class-def
455 (lambda () (def :default-initargs
))
456 '((dolist (x (reverse (cleanup-parsed-parameter value
)))
457 (push x
(def :default-initargs
))))
460 (defmacro deftestsuite
(testsuite-name superclasses slots
&rest
463 Creates a testsuite named `testsuite-name` and, optionally, the code required for test setup, test tear-down and the actual test-cases. A testsuite is a collection of test-cases and other testsuites.
465 Test suites can have multiple superclasses (just like the classes that they are). Usually, these will be other test classes and the class hierarchy becomes the test case hierarchy. If necessary, however, non-testsuite classes can also be used as superclasses.
467 Slots are specified as in defclass with the following additions:
469 * Initargs and accessors are automatically defined. If a slot is named`my-slot`, then the initarg will be `:my-slot` and the accessors will be `my-slot` and `(setf my-slot)`.
470 * If the second argument is not a CLOS slot option keyword, then it will be used as the `:initform` for the slot. I.e., if you have
472 (deftestsuite my-test ()
475 then `my-slot` will be initialized to 23 during test setup.
477 Test options are one of :setup, :teardown, :test, :tests, :documentation, :export-p, :dynamic-variables, :export-slots, :function, :categories, :run-setup, or :equality-test.
479 * :categories - a list of symbols. Categories allow you to groups tests into clusters outside of the basic hierarchy. This provides finer grained control on selecting which tests to run. May be specified multiple times.
481 * :documentation - a string specifying any documentation for the test. Should only be specified once.
483 * :dynamic-variables - a list of atoms or pairs of the form (name value). These specify any special variables that should be bound in a let around the body of the test. The name should be symbol designating a special variable. The value (if supplied) will be bound to the variable. If the value is not supplied, the variable will be bound to nil. Should only be specified once.
485 * :equality-test - the name of the function to be used by default in calls to ensure-same and ensure-different. Should only be supplied once.
487 * :export-p - If true, the testsuite name will be exported from the current package. Should only be specified once.
489 * :export-slots - if true, any slots specified in the test suite will be exported from the current package. Should only be specified once.
491 * :function - creates a locally accessible function for this test suite. May be specified multiple times.
493 * :run-setup - specify when to run the setup code for this test suite. Allowed values are
495 * :once-per-test-case or t (the default)
500 :run-setup is handy when a testsuite has a time consuming setup phase that you do not want to repeat for every test.
502 * :setup - a list of forms to be evaluated before each test case is run. Should only be specified once.
504 * :teardown - a list of forms to be evaluated after each test case is run. Should only be specified once.
506 * :test - Define a single test case. Can be specified multiple times.
508 * :tests - Define multiple test cases for this test suite. Can be specified multiple times.
513 (let ((test-list nil
)
516 ;; convert any clause like :setup foo into (:setup foo)
517 (setf clauses-and-options
518 (convert-clauses-into-lists clauses-and-options
*deftest-clauses
*))
519 (initialize-current-definition)
520 (setf (def :testsuite-name
) testsuite-name
)
521 (setf (def :superclasses
) (mapcar (lambda (class) (find-testsuite class
:errorp t
))
523 (setf (def :deftestsuite
) t
)
524 ;; parse clauses into defs
525 (loop for clause in clauses-and-options do
527 (symbol (pushnew clause options
))
528 (cons (destructuring-bind (kind &rest spec
) clause
530 (:test
(push (first spec
) test-list
))
532 (loop for test in spec do
533 (push test test-list
)))
534 (t (block-handler kind spec
)))))
535 (t (error "When parsing ~S" clause
))))
536 (let ((slot-names nil
) (slot-specs nil
))
537 (loop for slot in
(if (listp slots
) slots
(list slots
)) do
538 (push (if (consp slot
) (first slot
) slot
) slot-names
)
539 (push (parse-brief-slot slot
) slot-specs
))
540 (setf (def :slot-specs
) (nreverse slot-specs
)
541 (def :direct-slot-names
) (nreverse slot-names
)
542 (def :slots-parsed
) t
))
543 ;;?? issue 27: breaks 'encapsulation' of code-block mechanism
544 (setf (def :function-specs
)
545 (loop for spec in
(def :functions
) collect
546 (destructuring-bind (name arglist
&body body
) (first spec
)
547 (declare (ignore body
))
550 (empty-test-tables testsuite-name
)
551 (compute-superclass-inheritence)
553 (setf *testsuite-test-count
* 0)
554 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
555 (eval-when (:compile-toplevel
)
556 (push ',return
*test-is-being-compiled?
*))
557 (eval-when (:load-toplevel
)
558 (push ',return
*test-is-being-loaded?
*))
559 (eval-when (:execute
)
560 (push ',return
*test-is-being-executed?
*))
561 ;; remove previous methods (do this _before_ we define the class)
562 (unless (or *test-is-being-compiled?
*
563 *test-is-being-loaded?
*)
564 (remove-previous-definitions ',(def :testsuite-name
)))
567 (let ((*test-is-being-defined?
* t
))
568 (setf *last-test-case-name
* nil
)
569 (setf *last-testsuite-name
* ',(def :testsuite-name
)
570 (test-slots ',(def :testsuite-name
))
572 (testsuite-dynamic-variables ',(def :testsuite-name
))
573 ',(def :dynamic-variables
)
574 ;;?? issue 27: breaks 'encapsulation' of code-block
576 (testsuite-function-specs ',(def :testsuite-name
))
577 ',(def :function-specs
))
578 ,@(when (def :export-p
)
579 `((export '(,(def :testsuite-name
)))))
580 ,@(when (def :export-slots?
)
581 `((export ',(def :direct-slot-names
))))
582 ;; make a place to save test-case information
583 (empty-test-tables ',(def :testsuite-name
))
586 ,@(loop for
(nil . block
) in
*code-blocks
*
589 (eq (operate-when block
) :methods
)
590 (or (not (filter block
))
591 (funcall (filter block
)))) collect
592 (funcall (code block
)))
593 ,@(when (def :dynamic-variables
)
594 `((defmethod do-testing :around
595 ((suite ,(def :testsuite-name
)) result fn
)
596 (declare (ignore result fn
)
599 #'car
(def :dynamic-variables
))))
601 (cond ((done-dynamics? suite
)
604 (setf (slot-value suite
'done-dynamics?
) t
)
605 (let* (,@(def :dynamic-variables
))
608 #'car
(def :dynamic-variables
))))
609 (call-next-method))))))))
612 `((let ((*test-evaluate-when-defined?
* nil
))
613 ,@(loop for test in
(nreverse test-list
) collect
614 `(addtest (,(def :testsuite-name
))
616 (setf *testsuite-test-count
* nil
))))
617 ,(if (and test-list
*test-evaluate-when-defined?
*)
618 `(unless (or *test-is-being-compiled?
*
619 *test-is-being-loaded?
*)
620 (let ((*test-break-on-errors?
* *test-break-on-errors?
*))
621 (run-tests :suite
',testsuite-name
)))
622 `(find-class ',testsuite-name
)))
624 (setf *test-is-being-compiled?
*
625 (remove ',return
*test-is-being-compiled?
*))
626 (setf *test-is-being-loaded?
*
627 (remove ',return
*test-is-being-loaded?
*))
628 (setf *test-is-being-executed?
*
629 (remove ',return
*test-is-being-executed?
*)))))))
631 (defun compute-superclass-inheritence ()
632 ;;?? issue 27: break encapsulation of code blocks
633 ;;?? we assume that we won't have too deep a hierarchy or too many
634 ;; dv's or functions so that having lots of duplicate names is OK
636 (inherited-dynamic-variables nil
)
637 (dynamic-variables (%build-pairs
(def :direct-dynamic-variables
)))
638 (function-specs nil
))
639 (dolist (super (def :superclasses
))
640 (cond ((find-testsuite super
)
641 (setf slots
(append slots
(test-slots super
))
642 inherited-dynamic-variables
643 (append inherited-dynamic-variables
644 (testsuite-dynamic-variables super
))
646 (append function-specs
647 (testsuite-function-specs super
))))
649 (error 'testsuite-not-defined
:testsuite-name super
))))
650 (loop for pair in inherited-dynamic-variables
651 unless
(find (first pair
) dynamic-variables
:key
#'first
) collect
652 (progn (push pair dynamic-variables
) pair
))
653 (setf (def :slot-names
)
654 (remove-duplicates (append (def :direct-slot-names
) slots
))
655 (def :dynamic-variables
) (nreverse dynamic-variables
)
656 (def :function-specs
)
658 (append (def :function-specs
) function-specs
)))
659 (setf (def :superclasses
)
660 (loop for class in
(def :superclasses
)
661 unless
(some (lambda (oter)
662 (and (not (eq class oter
))
663 (member class
(superclasses oter
))))
664 (def :superclasses
)) collect
667 (defun %build-pairs
(putative-pairs)
669 (dolist (putative-pair putative-pairs
)
670 (if (atom putative-pair
)
671 (push (list putative-pair nil
) result
)
672 (push putative-pair result
)))
675 (defmacro addtest
(name &body test
)
676 "Adds a single new test-case to the most recently defined testsuite."
682 (options nil
) (documentation nil
)
683 (looks-like-suite-name (looks-like-suite-name-p name
)))
684 (cond (looks-like-suite-name
686 (setf (def :testsuite-name
) (first name
)
690 ;; the 'name' is really part of the test...
691 (setf body
(cons name test
))))
692 (unless (property-list-p options
)
693 (signal-lift-error 'add-test
"test-case options must be a property list and \"~s`\" is not" options
))
694 (when (getf options
:documentation
)
695 (setf documentation
(getf options
:documentation
))
696 (remf options
:documentation
))
697 (unless (def :testsuite-name
)
698 (when *last-testsuite-name
*
699 (setf (def :testsuite-name
) *last-testsuite-name
*)))
700 (unless (def :testsuite-name
)
701 (signal-lift-error 'add-test
+lift-no-current-test-class
+))
702 (unless (or (def :deftestsuite
)
703 (find-testsuite (def :testsuite-name
)))
704 (signal-lift-error 'add-test
+lift-test-class-not-found
+
705 (def :testsuite-name
)))
706 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
707 (eval-when (:compile-toplevel
)
708 (push ',return
*test-is-being-compiled?
*))
709 (eval-when (:load-toplevel
)
710 (push ',return
*test-is-being-loaded?
*))
711 (eval-when (:execute
)
712 (push ',return
*test-is-being-executed?
*))
714 (let ((*test-is-being-defined?
* t
))
715 (muffle-redefinition-warnings
716 ,(build-test-test-method (def :testsuite-name
) body options
))
717 ,@(when documentation
719 ',(def :test-case-name
)
720 (test-case-documentation ',(def :testsuite-name
)))
722 ,@(when *compile-file-pathname
*
724 ',(def :test-case-name
)
725 (test-case-source-file ',(def :testsuite-name
)))
726 ,(namestring *compile-file-pathname
*))))
727 (setf *last-testsuite-name
* ',(def :testsuite-name
))
728 (if *test-evaluate-when-defined?
*
729 (unless (or *test-is-being-compiled?
*
730 *test-is-being-loaded?
*)
731 (let ((*test-break-on-errors?
* (testing-interactively-p)))
735 (setf *test-is-being-compiled?
*
736 (remove ',return
*test-is-being-compiled?
*)
737 *test-is-being-loaded?
*
738 (remove ',return
*test-is-being-loaded?
*)
739 *test-is-being-executed?
*
740 (remove ',return
*test-is-being-executed?
*))))))
742 (defmacro addbenchmark
((suite-name &rest options
) test-case-name
&body body
)
743 "Adds a single new test-benchmark to testsuite suite-name."
747 (let ((documentation nil
))
748 (unless (property-list-p options
)
751 "benchmark options must be a property list and \"~s`\" is not" options
))
752 (when (getf options
:documentation
)
753 (setf documentation
(getf options
:documentation
))
754 (remf options
:documentation
))
756 (signal-lift-error 'addbenchmark
+lift-no-current-test-class
+))
757 (unless (find-testsuite suite-name
)
759 'addbenchmark
+lift-test-class-not-found
+ suite-name
))
760 (setf (def :testsuite-name
) suite-name
761 (def :test-case-name
) test-case-name
)
762 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
763 (let ((*test-is-being-defined?
* t
))
764 (muffle-redefinition-warnings
765 ,(build-benchmark-function
766 suite-name test-case-name body options
))
767 ,@(when documentation
769 ',(def :test-case-name
)
770 (test-case-documentation ',(def :testsuite-name
)))
772 (setf *last-testsuite-name
* ',(def :testsuite-name
))
773 ',(def :test-case-name
)))))
775 (defun looks-like-suite-name-p (form)
778 (find-testsuite (first form
))))
780 (defun property-list-p (form)
785 for want-keyword?
= t then
(not want-keyword?
) do
786 (when (and want-keyword?
(not (keywordp x
)))
787 (return-from check-it nil
))
788 (setf even?
(not even?
)))
789 (return-from check-it even?
)))))
792 (property-list-p '(:a
:b
))
793 (property-list-p '(:a
2 :b
3 :c
5 :d
8))
794 (property-list-p nil
)
797 (property-list-p '(3))
798 (property-list-p '(3 :a
))
799 (property-list-p '(:a
3 :b
))
802 (defun remove-test (&key
(test-case *last-test-case-name
*)
803 (suite *last-testsuite-name
*))
804 (assert suite nil
"Test suite could not be determined.")
805 (assert test-case nil
"Test-case could not be determined.")
806 (setf (testsuite-tests suite
)
807 (remove test-case
(testsuite-tests suite
))))
809 (defun make-testsuite (suite-name args
)
810 (let ((testsuite (find-testsuite suite-name
:errorp t
))
813 (setf result
(apply #'make-instance testsuite args
))
814 (error "Testsuite ~a not found." suite-name
))
817 (defun skip-test-case-p (result suite-name test-case-name
)
818 (declare (ignore result
))
819 (find-if (lambda (skip-datum)
821 (and (eq suite-name
(car skip-datum
))
822 (eq test-case-name
(cdr skip-datum
)))
823 (subtypep suite-name
(car skip-datum
))))
826 (defun skip-test-suite-children-p (result suite-name
)
827 (declare (ignore result
))
828 (find-if (lambda (skip-datum)
829 (and (subtypep suite-name
(car skip-datum
))
830 (null (cdr skip-datum
))))
833 (defmethod skip-test-case (result suite-name test-case-name
)
834 (report-test-problem 'testcase-skipped result suite-name test-case-name nil
))
836 (defmethod skip-testsuite (result suite-name
)
837 (report-test-problem 'testsuite-skipped result suite-name nil nil
))
839 (defun test-case-expects-error-p (suite-name test-case-name
)
840 (or (testsuite-expects-error *current-test
*)
841 (test-case-option suite-name test-case-name
:expected-error
)))
843 (defun test-case-expects-failure-p (suite-name test-case-name
)
844 (or (testsuite-expects-failure *current-test
*)
845 (test-case-option suite-name test-case-name
:expected-failure
)))
847 (defun test-case-expects-problem-p (suite-name test-case-name
)
848 (test-case-option suite-name test-case-name
:expected-problem
))
850 (defun check-for-surprises (suite-name test-case-name
)
851 (let* ((expected-failure-p (test-case-expects-failure-p
852 suite-name test-case-name
))
853 (expected-error-p (test-case-expects-error-p
854 suite-name test-case-name
))
855 (expected-problem-p (test-case-expects-problem-p
856 suite-name test-case-name
))
861 (make-condition 'unexpected-success-failure
863 :expected-more expected-failure-p
)))
866 (make-condition 'unexpected-success-failure
868 :expected-more expected-error-p
)))
871 (make-condition 'unexpected-success-failure
873 :expected-more expected-problem-p
))))
875 (if (find-restart 'ensure-failed
)
876 (invoke-restart 'ensure-failed condition
)
879 (defun error-okay-p (suite-name test-case-name
)
880 (or (test-case-expects-error-p suite-name test-case-name
)
881 (test-case-expects-problem-p suite-name test-case-name
)))
883 (defun failure-okay-p (suite-name test-case-name
)
884 (or (test-case-expects-failure-p suite-name test-case-name
)
885 (test-case-expects-problem-p suite-name test-case-name
)))
887 (defun report-test-problem (problem-type result suite-name method condition
892 (declare (ignorable docs option
))
893 (cond ((and (eq problem-type
'test-failure
)
894 (not (typep condition
'unexpected-success-failure
))
895 (test-case-expects-failure-p suite-name method
))
896 (setf problem-type
'test-expected-failure
897 option
:expected-failure
))
898 ((and (eq problem-type
'test-error
)
899 (test-case-expects-error-p suite-name method
))
900 (setf problem-type
'test-expected-error
901 option
:expected-error
))
902 ((and (or (eq problem-type
'test-failure
)
903 (eq problem-type
'test-error
))
904 (test-case-expects-problem-p suite-name method
))
905 (setf problem-type
(or (and (eq problem-type
'test-failure
)
906 'test-expected-failure
)
907 (and (eq problem-type
'test-error
)
908 'test-expected-error
))
909 option
:expected-problem
)))
910 (let ((problem (apply #'make-instance problem-type
911 :testsuite suite-name
913 :test-condition condition
914 :test-step
(current-step result
)
915 :testsuite-initargs
(testsuite-initargs result
)
918 (setf (getf (test-data *current-test
*) :problem
) problem
))
919 (accumulate-problem problem result
)
920 (when (and *test-maximum-failure-count
*
921 (numberp *test-maximum-failure-count
*)
922 (>= (length (failures result
)) *test-maximum-failure-count
*))
923 (cancel-testing :failures
))
924 (when (and *test-maximum-error-count
*
925 (numberp *test-maximum-error-count
*)
926 (>= (length (errors result
)) *test-maximum-error-count
*))
927 (cancel-testing :errors
))
930 (defun cancel-testing (why)
931 (declare (ignore why
))
933 (let ((restart (find-restart name
)))
934 (when restart
(invoke-restart restart
*test-result
*)))))
935 (do-it 'cancel-testing-from-configuration
)
936 (do-it 'cancel-testing
)))
938 ;;; ---------------------------------------------------------------------------
939 ;;; test-result and printing
940 ;;; ---------------------------------------------------------------------------
942 (defun get-test-print-length ()
943 (let ((foo *test-print-length
*))
944 (if (eq foo
:follow-print
) *print-length
* foo
)))
946 (defun get-test-print-level ()
947 (let ((foo *test-print-level
*))
948 (if (eq foo
:follow-print
) *print-level
* foo
)))
950 (defun record-start-times (result suite
)
951 (setf (current-step result
) :start-test
953 `(:start-time
,(get-test-real-time)
954 :start-time-universal
,(get-universal-time))))
956 (defun record-end-times (result suite
)
957 (setf (current-step result
) :end-test
958 (getf (test-data suite
) :end-time
) (get-test-real-time)
959 (end-time result
) (get-test-real-time)
960 (getf (test-data suite
) :end-time-universal
) (get-universal-time)
961 (end-time-universal result
) (get-universal-time)))
963 (defmethod make-test-result (for test-mode
&rest args
)
964 (apply #'make-instance
'test-result
969 (defun testing-interactively-p ()
972 (defmethod print-object ((tr test-result
) stream
)
973 (let ((complete-success?
(and (null (errors tr
))
975 (null (expected-failures tr
))
976 (null (expected-errors tr
)))))
977 (let* ((*print-level
* (get-test-print-level))
978 (*print-length
* (get-test-print-length))
979 (non-failure-failures
982 (member (class-of (test-condition failure
))
983 (subclasses 'unexpected-success-failure
:proper? nil
)))
984 (expected-failures tr
)))
985 (expected-failures (- (length (expected-failures tr
))
986 non-failure-failures
)))
987 (print-unreadable-object (tr stream
)
988 (cond ((and (null (tests-run tr
)) complete-success?
)
989 (format stream
"~A: no tests run" (results-for tr
)))
990 ((eq (test-mode tr
) :single
)
991 (cond ((test-interactive? tr
)
993 (cond (complete-success?
994 (format stream
"Test passed"))
996 (format stream
"Error during testing"))
997 ((expected-errors tr
)
998 (format stream
"Expected error during testing"))
1000 (format stream
"Test failed"))
1001 ((plusp non-failure-failures
)
1002 (format stream
"Test succeeded unexpectedly"))
1004 (format stream
"Test failed expectedly"))))
1007 (format stream
"~A.~A ~A"
1009 (second (first (tests-run tr
)))
1010 (cond (complete-success?
1016 (when (or (expected-errors tr
) (expected-failures tr
))
1017 (format stream
"(~[~:;, ~:*~A expected failure~:P~]~[~:;, ~:*~A succeeded unexpectedly~]~[~:;, ~:*~A expected error~:P~])"
1018 expected-failures non-failure-failures
1019 (expected-errors tr
))))))
1021 ;; multiple tests run
1022 (format stream
"Results for ~A " (results-for tr
))
1023 (if complete-success?
1024 (format stream
"[~A Successful test~:P]"
1025 (length (tests-run tr
)))
1026 (format stream
"~A Test~:P~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Error~:P~]~[~:;, ~:*~A Expected failure~:P~]~[~:;, ~:*~A Expected error~:P~]"
1027 (length (tests-run tr
))
1028 (length (failures tr
))
1029 (length (errors tr
))
1030 (length (expected-failures tr
))
1031 (length (expected-errors tr
))))))
1032 ;; note that suites with no tests think that they are completely
1033 ;; successful. Optimistic little buggers, huh?
1034 (when (and (not complete-success?
) *test-describe-if-not-successful?
*)
1035 (format stream
"~%")
1036 (print-test-result-details stream tr t t
))))))
1038 (defmethod describe-object ((result test-result
) stream
)
1039 (describe-test-result result stream
))
1041 (defmethod describe-test-result (result stream
1043 (show-details-p *test-show-details-p
*)
1044 (show-expected-p *test-show-expected-p
*)
1045 (show-code-p *test-show-code-p
*))
1046 (let* ((number-of-failures (length (failures result
)))
1047 (number-of-errors (length (errors result
)))
1048 (number-of-expected-errors (length (expected-errors result
)))
1049 (non-failure-failures
1052 (member (class-of (test-condition failure
))
1053 (subclasses 'unexpected-success-failure
:proper? nil
)))
1054 (expected-failures result
)))
1055 (number-of-expected-failures (- (length (expected-failures result
))
1056 non-failure-failures
))
1057 (*print-level
* (get-test-print-level))
1058 (*print-length
* (get-test-print-length)))
1059 (unless *test-is-being-defined?
*
1060 (print-test-summary result stream
)
1061 (when (and show-details-p
1062 (or (plusp number-of-failures
)
1063 (plusp number-of-expected-failures
)
1064 (plusp number-of-errors
)
1065 (plusp number-of-expected-errors
)))
1066 (format stream
"~%~%")
1067 (print-test-result-details
1068 stream result show-expected-p show-code-p
)
1069 (print-test-summary result stream
)))))
1071 (defun print-test-summary (result stream
)
1072 (let* ((number-of-failures (length (failures result
)))
1073 (number-of-errors (length (errors result
)))
1074 (number-of-expected-errors (length (expected-errors result
)))
1075 (non-failure-failures
1078 (member (class-of (test-condition failure
))
1079 (subclasses 'unexpected-success-failure
:proper? nil
)))
1080 (expected-failures result
)))
1081 (number-of-expected-failures (- (length (expected-failures result
))
1082 non-failure-failures
)))
1083 (format stream
"~&Test Report for ~A: ~D test~:P run"
1084 (results-for result
) (length (tests-run result
)))
1085 (cond ((or (failures result
) (errors result
)
1086 (expected-failures result
) (expected-errors result
))
1087 (format stream
"~[~:;, ~:*~A Error~:P~]~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Expected error~:P~]~[~:;, ~:*~A Expected failure~:P~]~[~:;, ~:*~A Successful Surprise~:P~]."
1090 number-of-expected-errors
1091 number-of-expected-failures
1092 non-failure-failures
))
1093 ((or (expected-failures result
) (expected-errors result
))
1094 (format stream
", all passed *~[~:;, ~:*~A Expected error~:P~]~[~:;, ~:*~A Expected failure~:P~])."
1095 number-of-expected-errors
1096 number-of-expected-failures
))
1098 (format stream
", all passed!")))))
1100 (defun print-test-result-details (stream result show-expected-p show-code-p
)
1101 (loop for report in
(errors result
) do
1102 (print-test-problem "ERROR :" report stream
1104 (loop for report in
(failures result
) do
1105 (print-test-problem "Failure:" report stream
1107 (when show-expected-p
1108 (loop for report in
(expected-failures result
) do
1109 (print-test-problem "Expected failure:" report stream
1111 (loop for report in
(expected-errors result
) do
1112 (print-test-problem "Expected Error :" report stream
1115 (defmethod print-test-problem (prefix (report testsuite-problem-mixin
) stream show-code-p
)
1116 (let* ((suite-name (testsuite report
))
1117 (method (test-method report
))
1118 (condition (test-condition report
))
1119 (code (test-report-code suite-name method
))
1120 (step (test-step report
))
1121 (testsuite-name method
)
1122 (*print-level
* (get-test-print-level))
1123 (*print-length
* (get-test-print-length)))
1124 (let ((*package
* (symbol-package method
))
1125 (doc-string (gethash testsuite-name
1126 (test-case-documentation suite-name
)))
1127 (source-file (gethash testsuite-name
1128 (test-case-source-file suite-name
))))
1129 (format stream
"~&~A ~(~A : ~A~)" prefix suite-name testsuite-name
)
1131 (setf code
(with-output-to-string (out)
1134 (format stream
"~&~< ~@;~
1135 ~@[Documentation: ~<~@;~a~:>~]~
1136 ~@[~&Source : ~<~@;~a~:>~]~
1137 ~@[~&Condition : ~<~@;~a~:>~]~
1140 ~&~:>" (list doc-string source-file
(list condition
) step code
)))))
1142 (defmethod print-test-problem (prefix (report test-configuration-problem-mixin
) stream show-code-p
)
1143 (declare (ignore show-code-p
))
1144 (format stream
"~&~A ~a~%~%" prefix
(test-problem-message report
)))
1147 ;;; ---------------------------------------------------------------------------
1149 ;;; ---------------------------------------------------------------------------
1151 (defun test-report-code (suite-name test-case-name
)
1152 (gethash test-case-name
(test-name->code-table suite-name
)))
1154 ;;; ---------------------------------------------------------------------------
1156 ;;; ---------------------------------------------------------------------------
1158 (defun remove-test-methods (test-name)
1160 (length (testsuite-tests test-name
))
1161 (setf (testsuite-tests test-name
) nil
)))
1163 (defun remove-previous-definitions (classname)
1164 "Remove the methods of this class and all its subclasses."
1165 (let ((classes-removed nil
)
1166 (class (find-class classname nil
))
1169 (loop for subclass in
(subclasses class
:proper? nil
) do
1170 (push subclass classes-removed
)
1172 (remove-test-methods (class-name subclass
)))
1174 ;;?? causing more trouble than it solves...??
1175 (setf (find-class (class-name subclass
)) nil
))
1177 (unless (length-1-list-p classes-removed
)
1179 "~&;;; Removed Test suite ~(~A~) and its subclasses (~{~<~s~>~^, ~})."
1182 (mapcar #'class-name classes-removed
))
1184 (unless (zerop removed-count
)
1186 "~&;;; Removed ~D methods from test suite ~(~A~)~@[ and its subclasses~]."
1187 removed-count classname
1188 (not (length-1-list-p classes-removed
)))))))
1190 (defun (setf test-environment-value
) (value name
)
1191 (setf (slot-value *current-test
* name
) value
))
1193 (defun test-environment-value (name)
1194 (slot-value *current-test
* name
))
1196 (defun build-test-local-functions ()
1199 (lambda (function-spec)
1200 (destructuring-bind (name arglist
&body body
) (first function-spec
)
1201 `(defmethod flet-test-function ((testsuite ,(def :testsuite-name
))
1202 (function-name (eql ',name
))
1206 `(destructuring-bind ,arglist args
1208 `(progn ,@body
))))))
1211 (defun build-test-equality-test ()
1212 (let ((test-name (def :testsuite-name
))
1213 (equality-test (def :equality-test
)))
1215 (defmethod equality-test ((testsuite ,test-name
))
1218 (defun build-testsuite-expected-error ()
1219 (let ((test-name (def :testsuite-name
))
1220 (expected-error (def :expected-error
)))
1222 (defmethod testsuite-expects-error ((testsuite ,test-name
))
1224 ,expected-error
)))))
1226 (defun build-testsuite-expected-failure ()
1227 (let ((test-name (def :testsuite-name
))
1228 (expected-failure (def :expected-failure
)))
1230 (defmethod testsuite-expects-failure ((testsuite ,test-name
))
1232 ,expected-failure
)))))
1234 (defun build-test-teardown-method ()
1235 (let ((test-name (def :testsuite-name
))
1236 (teardown (def :teardown
)))
1238 (unless (consp teardown
)
1239 (setf teardown
(list teardown
)))
1240 (when (length-1-list-p teardown
)
1241 (setf teardown
(list teardown
)))
1242 (when (symbolp (first teardown
))
1243 (setf teardown
(list teardown
))))
1244 (let* ((teardown-code `(,@(when teardown
1245 `((with-test-slots ,@teardown
)))))
1246 (test-code `(,@teardown-code
)))
1248 ,@(when teardown-code
1249 `((defmethod test-case-teardown progn
((testsuite ,test-name
)
1250 (result test-result
))
1251 (when (run-teardown-p testsuite
:test-case
)
1253 ,@(when teardown-code
1254 `((defmethod testsuite-teardown ((testsuite ,test-name
)
1255 (result test-result
))
1256 (when (run-teardown-p testsuite
:testsuite
)
1259 (defun build-setup-test-method ()
1260 (let ((test-name (def :testsuite-name
))
1261 (setup (def :setup
)))
1262 ;;?? ewww, this smells bad
1264 (unless (consp setup
)
1265 (setf setup
(list setup
)))
1266 (when (length-1-list-p setup
)
1267 (setf setup
(list setup
)))
1268 (when (symbolp (first setup
))
1269 (setf setup
(list setup
))))
1271 `(defmethod setup-test :after
((testsuite ,test-name
))
1274 ;; rather use remove-method
1275 `(defmethod setup-test :after
((testsuite ,test-name
))
1278 (defmethod setup-test :around
((test test-mixin
))
1279 (when (run-setup-p test
)
1281 (setf (slot-value test
'done-setup?
) t
)))
1283 (defun run-setup-p (testsuite)
1284 (case (run-setup testsuite
)
1285 (:once-per-session
(error "not implemented"))
1286 (:once-per-suite
(not (done-setup? testsuite
)))
1287 ((:once-per-test-case t
) t
)
1289 (t (error "Don't know about ~s for run-setup" (run-setup testsuite
)))))
1291 (defun run-teardown-p (testsuite when
)
1294 (ecase (run-setup testsuite
)
1295 (:once-per-session nil
)
1296 (:once-per-suite nil
)
1297 ((:once-per-test-case t
) t
)
1298 ((:never nil
) nil
)))
1300 (ecase (run-setup testsuite
)
1301 (:once-per-session nil
)
1303 ((:once-per-test-case t
) nil
)
1304 ((:never nil
) nil
)))))
1306 (defun build-test-test-method (suite-name test-body options
)
1307 (multiple-value-bind (test-case-name body name-supplied?
)
1308 (parse-test-body test-body
)
1309 (declare (ignorable name-supplied?
))
1310 (unless (consp (first body
))
1311 (setf body
(list body
)))
1312 (setf (def :test-case-name
) test-case-name
)
1314 (setf (gethash ',test-case-name
(test-name->code-table
',suite-name
)) ',body
1315 (gethash ',body
(test-code->name-table
',suite-name
)) ',test-case-name
)
1317 ,@(when name-supplied?
1318 `((ccl:record-source-file
',test-case-name
'test-case
)))
1319 (unless (find ',test-case-name
(testsuite-tests ',suite-name
))
1320 (setf (testsuite-tests ',suite-name
)
1321 (append (testsuite-tests ',suite-name
) (list ',test-case-name
))))
1322 (setf (gethash ',suite-name
*test-case-options
*) nil
)
1323 (defmethod set-test-case-options
1324 ((suite-name (eql ',suite-name
)) (test-case-name (eql ',test-case-name
)))
1326 (build-test-case-options
1327 suite-name test-case-name options
)))
1328 (setf (gethash ',test-case-name
(test-name->methods
',suite-name
))
1330 (declare (ignorable testsuite
))
1332 `((set-test-case-options ',suite-name
',test-case-name
)))
1333 (with-test-slots ,@body
)))
1334 (setf *last-test-case-name
* ',test-case-name
)
1335 (when (and *test-print-when-defined?
*
1336 (not (or *test-is-being-compiled?
*
1338 (format *debug-io
* "~&;Test Created: ~(~S.~S~)."
1339 ',suite-name
',test-case-name
))
1340 *last-test-case-name
*)))
1342 (defun parse-test-body (test-body)
1343 (let ((test-name nil
)
1345 (test-number (1+ (testsuite-test-count *last-testsuite-name
*)))
1346 (name-supplied? nil
))
1347 (setf test-name
(first test-body
))
1348 (cond ((symbolp test-name
)
1350 (intern (format nil
"~A" test-name
))
1351 body
(rest test-body
)
1353 ((and (test-code->name-table
*last-testsuite-name
*)
1356 (test-code->name-table
*last-testsuite-name
*))))
1357 (setf body test-body
))
1360 (intern (format nil
"TEST-~A"
1363 (values test-name body name-supplied?
)))
1365 (defun build-benchmark-function (suite-name test-case-name body options
)
1366 (let ((duration 2) style
)
1367 (when (getf options
:style
)
1368 (setf style
(getf options
:style
))
1369 (remf options
:style
))
1370 (when (getf options
:duration
2)
1371 (setf duration
(getf options
:duration
2))
1372 (remf options
:duration
))
1375 ,@(when name-supplied?
1376 `((ccl:record-source-file
',test-case-name
'test-case
)))
1377 (unless (find ',test-case-name
(testsuite-tests ',suite-name
))
1378 (setf (testsuite-tests ',suite-name
)
1379 (append (testsuite-tests ',suite-name
) (list ',test-case-name
))))
1380 ;;?? to defer until after compile...?
1382 `((defmethod set-test-case-options
1383 ((suite-name (eql ',suite-name
))
1384 (test-case-name (eql ',test-case-name
)))
1385 ,@(build-test-case-options
1386 suite-name test-case-name options
))))
1387 (setf (gethash ',test-case-name
(test-name->methods
',suite-name
))
1389 (declare (ignorable testsuite
))
1393 (getf (test-data *current-test
*) :benchmark-count
)))
1394 (declare (ignorable benchmark-count
))
1396 `((set-test-case-options ',suite-name
',test-case-name
)))
1399 `((setf benchmark-count
1400 (while-counting-repetitions (,duration
)
1403 `((setf benchmark-count
1404 (while-counting-events (,duration
)
1408 (setf *last-test-case-name
* ',test-case-name
))))
1410 (defun build-test-class ()
1411 ;; for now, we don't generate code from :class-def code-blocks
1412 ;; they are executed only for effect.
1413 (loop for
(nil . block
) in
*code-blocks
*
1416 (eq (operate-when block
) :class-def
)
1417 (or (not (filter block
))
1418 (funcall (filter block
)))) collect
1419 (funcall (code block
)))
1420 (unless (some (lambda (superclass)
1421 (testsuite-p superclass
))
1422 (def :superclasses
))
1423 (pushnew 'test-mixin
(def :superclasses
)))
1424 ;; build basic class and standard class
1425 `(defclass ,(def :testsuite-name
) (,@(def :superclasses
))
1426 ,(loop for name in
(def :direct-slot-names
) collect
1427 (let ((it (find name
(def :slot-specs
) :key
#'car
)))
1430 ,@(when (def :documentation
)
1431 `((:documentation
,(def :documentation
))))
1433 ,@(def :default-initargs
)
1434 ,@(when *load-pathname
*
1435 `(:test-source-file
,(namestring *compile-file-pathname
*))))))
1437 (defun parse-test-slots (slot-specs)
1438 (loop for spec in slot-specs collect
1439 (let ((parsed-spec spec
))
1440 (if (member :initform parsed-spec
)
1441 (let ((pos (position :initform parsed-spec
)))
1442 (append (subseq parsed-spec
0 pos
)
1443 (subseq parsed-spec
(+ pos
2))))
1446 ;; some handy properties
1447 (defclass-property test-slots
)
1448 (defclass-property test-code-
>name-table
)
1449 (defclass-property test-name-
>code-table
)
1450 (defclass-property test-case-documentation
)
1451 (defclass-property testsuite-tests
)
1452 (defclass-property testsuite-dynamic-variables
)
1453 (defclass-property test-name-
>methods
)
1454 (defclass-property test-case-source-file
)
1456 ;;?? issue 27: break encapsulation of code blocks
1457 (defclass-property testsuite-function-specs
)
1459 (defun empty-test-tables (test-name)
1460 (when (find-class test-name nil
)
1461 (setf (test-code->name-table test-name
)
1462 (make-hash-table :test
#'equal
)
1463 (test-name->code-table test-name
)
1464 (make-hash-table :test
#'equal
)
1465 (test-name->methods test-name
)
1466 (make-hash-table :test
#'eq
)
1467 (test-case-documentation test-name
)
1468 (make-hash-table :test
#'equal
)
1469 (test-case-source-file test-name
)
1470 (make-hash-table :test
#'equal
))))
1472 (pushnew :timeout
*deftest-clauses
*)
1475 :timeout
1 :class-def
1476 (lambda () (def :timeout
))
1477 '((setf (def :timeout
) (cleanup-parsed-parameter value
)))
1479 (unless (some (lambda (super)
1480 (member (find-class 'process-test-mixin
)
1481 (superclasses super
)))
1482 (def :superclasses
))
1483 (pushnew 'process-test-mixin
(def :superclasses
)))
1484 (push (def :timeout
) (def :default-initargs
))
1485 (push :maximum-time
(def :default-initargs
))
1488 (defmethod do-test :around
((suite test-mixin
) name result
)
1489 (declare (ignore result
))
1491 (with-profile-report ((format nil
"~a-~a"
1492 (testsuite-name suite
) name
)
1495 (call-next-method)))
1497 (defmethod do-test :around
((suite process-test-mixin
) name result
)
1498 (declare (ignore name
))
1499 (handler-bind ((timeout-error
1501 (let ((suite-name (class-name (class-of suite
))))
1502 (report-test-problem
1503 'test-timeout-failure result suite-name
(current-method suite
)
1504 (make-instance 'test-timeout-condition
1505 :maximum-time
(maximum-time suite
))))
1506 (if (find-restart 'test-failed
)
1507 (invoke-restart 'test-failed c
)
1509 (with-timeout ((maximum-time suite
))
1513 (defmethod testsuite-log-data ((suite t
))
1516 (defmethod testsuite-log-data :around
((suite t
))
1517 (multiple-value-bind (additional error?
)
1518 (ignore-errors (call-next-method))
1520 `(:error
"error occured gathering additional data")
1523 (defmethod test-case-teardown :around
((suite log-results-mixin
) result
)
1524 (declare (ignore result
))
1525 (let ((problem (getf (test-data suite
) :problem
)))
1526 (unless (and problem
(typep problem
'test-error-mixin
))
1529 (getf (test-data suite
) :seconds
)
1530 (getf (test-data suite
) :conses
)
1532 `(,@(testsuite-log-data suite
))))))
1534 ;;?? might be "cleaner" with a macrolet (cf. lift-result)
1535 (defun lift-property (name)
1536 (when *current-test
*
1537 (getf (getf (test-data *current-test
*) :properties
) name
)))
1540 (setf (getf (getf (third (first (tests-run *test-result
*))) :properties
) :foo
)
1543 (defun (setf lift-property
) (value name
)
1544 (when *current-test
*
1545 (setf (getf (getf (test-data *current-test
*) :properties
) name
) value
)))
1549 (defmacro with-test
(&body forms
)
1550 "Execute forms in the context of the current test class."
1551 (let* ((testsuite-name *last-testsuite-name
*)
1552 (test-case (make-instance test-class
)))
1553 `(eval-when (:execute
)
1555 (setup-test ,test-case
)
1557 (with-test-slots ,@forms
))
1558 (test-case-teardown ,test-case result
)))))
1560 (defvar *test-case-options
* (make-hash-table))
1562 (defun remove-test-case-options (suite-name)
1563 (remhash suite-name
*test-case-options
*))
1565 (defun test-case-option (suite-name case-name option-name
)
1566 (let* ((suite-options (gethash suite-name
*test-case-options
*))
1567 (case-options (and suite-options
1568 (gethash case-name suite-options
))))
1569 (getf (car case-options
) option-name
)))
1571 (defun (setf test-case-option
) (value suite-name case-name option-name
)
1572 (let ((suite-options (gethash suite-name
*test-case-options
*)))
1573 (unless suite-options
1574 (setf suite-options
(setf (gethash suite-name
*test-case-options
*)
1575 (make-hash-table))))
1576 (multiple-value-bind (case-options found?
)
1577 (gethash case-name suite-options
)
1580 (setf (gethash case-name suite-options
) (cons nil nil
))))
1581 (setf (getf (car case-options
) option-name
) value
))))
1583 (defun build-test-case-options (suite-name case-name options
)
1584 (loop for
(k v
) on options by
#'cddr collect
1585 `(setf (test-case-option ',suite-name
',case-name
,k
) ,v
)))
1588 (test-case-option 'test-dependencies-helper
'test-c
:depends-on
)
1589 (setf (test-case-option 'test-dependencies-helper
'test-c
:depends-on
) :test-c
)
1590 (remove-test-case-options 'test-dependencies-helper
)