1 ;;;-*- Mode: Lisp; Package: lift -*-
5 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
29 *test-ignore-warnings?
*
30 *test-break-on-errors?
*
31 *test-break-on-failures?
*
34 *test-print-when-defined?
*
35 *test-evaluate-when-defined?
*
36 *test-describe-if-not-successful?
*
38 *test-print-testsuite-names
*
39 *test-print-test-case-names
*
40 *lift-dribble-pathname
*
41 *lift-report-pathname
*
47 *test-show-expected-p
*
73 ensure-random-cases-failure
74 random-instance-for-suite
89 ;;; ---------------------------------------------------------------------------
91 ;;; ---------------------------------------------------------------------------
93 (defgeneric get-class
(thing &key error?
)
94 (:documentation
"Returns the class of thing or nil if the class cannot be found. Thing can be a class, an object representing a class or a symbol naming a class. Get-class is like find-class only not as particular.")
95 (:method
((thing symbol
) &key error?
)
96 (find-class thing error?
))
97 (:method
((thing standard-object
) &key error?
)
98 (declare (ignore error?
))
100 (:method
((thing t
) &key error?
)
101 (declare (ignore error?
))
103 (:method
((thing class
) &key error?
)
104 (declare (ignore error?
))
107 (defun direct-subclasses (thing)
108 "Returns the immediate subclasses of thing. Thing can be a class, object or symbol naming a class."
109 (class-direct-subclasses (get-class thing
)))
111 (defun map-subclasses (class fn
&key proper?
)
112 "Applies fn to each subclass of class. If proper? is true, then
113 the class itself is not included in the mapping. Proper? defaults to nil."
114 (let ((mapped (make-hash-table :test
#'eq
)))
115 (labels ((mapped-p (class)
116 (gethash class mapped
))
118 (unless (mapped-p class
)
119 (setf (gethash class mapped
) t
)
120 (unless (and proper? root
)
122 (mapc (lambda (class)
124 (direct-subclasses class
)))))
125 (do-it (get-class class
) t
))))
127 (defun subclasses (class &key
(proper? t
))
128 "Returns all of the subclasses of the class including the class itself."
130 (map-subclasses class
(lambda (class)
135 (defun superclasses (thing &key
(proper? t
))
136 "Returns a list of superclasses of thing. Thing can be a class, object or symbol naming a class. The list of classes returned is 'proper'; it does not include the class itself."
137 (let ((result (class-precedence-list (get-class thing
))))
138 (if proper?
(rest result
) result
)))
140 (defun direct-superclasses (thing)
141 "Returns the immediate superclasses of thing. Thing can be a class, object or symbol naming a class."
142 (class-direct-superclasses (get-class thing
)))
144 (declaim (inline length-1-list-p
))
145 (defun length-1-list-p (x)
146 "Is x a list of length 1?"
147 (and (consp x
) (null (cdr x
))))
149 (defmacro defclass-property
(property &optional
(default nil default-supplied?
))
150 "Create getter and setter methods for 'property' on symbol's property lists."
151 (let ((real-name (intern (format nil
"~:@(~A~)" property
) :keyword
)))
153 (defgeneric ,property
(symbol))
154 (defgeneric (setf ,property
) (value symbol
))
155 (defmethod ,property
((class-name symbol
))
156 (get class-name
,real-name
,@(when default-supplied?
(list default
))))
157 (defmethod (setf ,property
) (value (class-name symbol
))
158 (setf (get class-name
,real-name
) value
)))))
160 (defvar *automatic-slot-accessors?
* nil
)
161 (defvar *automatic-slot-initargs?
* nil
)
162 (defvar *clos-slot-options
*
163 '(:initform
:initarg
:reader
:writer
164 :accessor
:documentation
:type
167 (defun parse-brief-slot
169 (automatic-accessors?
*automatic-slot-accessors?
*)
170 (automatic-initargs?
*automatic-slot-initargs?
*)
172 (conc-separator "-"))
173 "Returns a verbose-style slot specification given a brief style, consisting of
174 a single symbol, the name of the slot, or a list of the slot name, optional
175 initform, optional symbol specifying whether there is an initarg, reader, or
176 accessor, and optional documentation string. The specification of initarg,
177 reader and accessor is done by the letters I, R and A, respectively; to specify
178 none of those, give a symbol containing none of those letters, such as the
179 symbol *. This function is used in the macro `defclass-brief,' but has been
180 broken out as a function in its own right for those writing variants on the
181 `defclass' macro. If a verbose-style slot specification is given, it is
184 If `automatic-accessors? is true, an accessor is defined, whether A is
185 specified or not _unless_ R is specified. If `automatic-initargs? is true,
186 an initarg is defined whether I is specified or not. If `conc-name' is
187 specified, the accessor name has that prepended, with conc-separator, and then
190 All other CLOS slot options are processed normally."
194 (symbol (setf slot
(list slot
)))
197 (let* ((name (pop slot
))
198 (new-slot (list name
))
201 (done-documentation? nil
)
203 (accessor-added? nil
)
204 (initargs-added? nil
))
205 (flet ((make-conc-name ()
207 (intern (format nil
"~@:(~A~A~A~)"
208 conc-name conc-separator name
))
211 (add-option (option argument
)
212 (push option new-slot
)
213 (push argument new-slot
))
215 ;; Remove duplicate options before returning the slot spec.
216 (finish-new-slot (slot)
217 ;; XXX This code is overly loopy and opaque ---L
218 (destructuring-bind (slot-name &rest options
) slot
219 (let ((opts (make-hash-table)))
220 (loop for
(key val . d
) = options then d
222 doing
(pushnew val
(gethash key opts nil
) :test
#'equal
))
223 (loop for key being each hash-key of opts using
(hash-value vals
)
224 nconc
(mapcan #'(lambda (x) (list key x
)) vals
) into spec
225 finally
(return (cons slot-name spec
)))))))
227 (do* ((items slot
(rest items
))
228 (item (first items
) (first items
))
230 (clos-item?
(member item
*clos-slot-options
*)
231 (member item
*clos-slot-options
*)))
234 (unless done-initform?
235 (setf done-initform? t
)
237 (setf process-item? nil
)
238 (unless (eq item
:UNBOUND
)
239 (push :initform new-slot
)
240 (push item new-slot
))))
243 (unless (or done-spec?
(not (symbolp item
)) clos-item?
)
245 (setf process-item? nil
)
246 ;; If you've got an A, who cares about R
247 (when (find #\A
(string item
))
248 (setf accessor-added? t
)
249 (add-option :accessor
(make-conc-name)))
250 (when (and (not accessor-added?
) (find #\R
(string item
)))
251 (setf reader-added? t
)
252 (add-option :reader
(make-conc-name)))
253 (when (find #\I
(string item
))
254 (setf initargs-added? t
)
255 (add-option :initarg
(intern (string name
)
256 (find-package :keyword
))))))
259 (unless (or done-documentation?
(not (stringp item
)))
260 (setf done-documentation? t
)
261 (push :documentation new-slot
)
269 (push (first items
) new-slot
))))
271 (when (and automatic-initargs?
(not initargs-added?
))
272 (add-option :initarg
(intern (string name
) (find-package :keyword
))))
274 (when (and automatic-accessors?
275 (and (not accessor-added?
) (not reader-added?
)))
276 (add-option :accessor
(make-conc-name)))
278 ;; finish-new-slot cleans up duplicates
279 (finish-new-slot (nreverse new-slot
)))))
281 (defun convert-clauses-into-lists (clauses-and-options clauses-to-convert
)
282 ;; This is useful (for me at least!) for writing macros
283 (let ((parsed-clauses nil
))
284 (do* ((clauses clauses-and-options
(rest clauses
))
285 (clause (first clauses
) (first clauses
)))
287 (if (and (keywordp clause
)
288 (or (null clauses-to-convert
) (member clause clauses-to-convert
))
289 (not (length-1-list-p clauses
)))
291 (setf clauses
(rest clauses
))
292 (push (list clause
(first clauses
)) parsed-clauses
))
293 (push clause parsed-clauses
)))
294 (nreverse parsed-clauses
)))
296 (defun remove-leading-quote (list)
297 "Removes the first quote from a list if one is there."
298 (if (and (consp list
) (eql (first list
) 'quote
))
302 (defun cleanup-parsed-parameter (parameter)
303 (if (length-1-list-p parameter
)
307 ;;; ---------------------------------------------------------------------------
308 ;;; global environment thingies
309 ;;; ---------------------------------------------------------------------------
311 (defparameter *make-testsuite-arguments
*
312 '(:run-setup
:test-slot-names
:equality-test
:log-file
:timeout
313 :default-initargs
:profile
:expected-failure
:expected-error
))
315 (defvar *current-testsuite-name
* nil
)
316 (defvar *current-test-case-name
* nil
)
318 (defvar *test-is-being-defined?
* nil
)
319 (defvar *test-is-being-compiled?
* nil
)
320 (defvar *test-is-being-loaded?
* nil
)
321 (defvar *test-is-being-executed?
* nil
)
323 (defvar *testsuite-test-count
* nil
324 "Temporary variable used to 'communicate' between deftestsuite and addtest.")
325 (defvar *lift-debug-output
* *debug-io
*
326 "Messages from LIFT will be sent to this stream. It can set to nil or
327 to an output stream. It defaults to *debug-io*.")
329 (defvar *test-maximum-time
* 2
330 "Maximum number of seconds a process test is allowed to run before we give up.")
332 (defvar *test-break-on-errors?
* nil
)
333 (defvar *test-break-on-failures?
* nil
)
334 (defvar *test-do-children?
* t
)
335 (defparameter *test-ignore-warnings?
* nil
336 "If true, LIFT will not cause a test to fail if a warning occurs while
337 the test is running. Note that this may interact oddly with ensure-warning.")
338 (defparameter *test-print-when-defined?
* nil
)
339 (defparameter *test-evaluate-when-defined?
* t
)
340 (defparameter *test-scratchpad
* nil
341 "A place to put things. This is set to nil before every test.")
342 (defparameter *test-notepad
* nil
343 "Another place to put things \(see {ref *test-scratchpad*}\).")
345 (defparameter *lift-equality-test
* 'equal
346 "The function used in ensure-same to test if two things are equal. If metatilities is loaded, then you might want to use samep.")
348 (defvar *test-describe-if-not-successful?
* nil
349 ;; Was t, but this behavior was extremely annoying since each
350 ;; time a test-restul appears in a stack backtrace it is printed
351 ;; over many unstructured lines.
352 "If true, then a complete test description is printed when there are any test warnings or failures. Otherwise, one would need to explicity call describe.")
354 (defvar *test-print-length
* :follow-print
355 "The print-length in effect when LIFT prints test results. It works exactly like `*print-length*` except that it can also take on the value :follow-print. In this case, it will be set to the value of `*print-length*`.")
356 (defvar *test-print-level
* :follow-print
357 "The print-level in effect when LIFT prints test results. It works exactly like `*print-level*` except that it can also take on the value :follow-print. In this case, it will be set to whatever `*print-level*` is.")
359 (defvar *test-print-testsuite-names
* t
360 "If true, LIFT will print the name of each test suite to *debug-io* before it begins to run the suite. See also: *test-print-test-case-names*.")
362 (defvar *test-print-test-case-names
* nil
363 "If true, LIFT will print the name of each test-case before it runs. See also: *test-print-testsuite-names*.")
365 (defparameter *lift-tests-to-skip
* nil
366 "A lift of test-suites and (testsuite test-case) pairs that LIFT will ignore
367 during calls to run-tests.")
369 (defvar *test-result
* nil
370 "Set to the most recent test result by calls to run-test or run-tests.")
372 (defvar *test-environment
* nil
)
374 (defvar *test-metadata
* (list)
375 "A place for LIFT to put stuff.")
377 (defvar *current-test
* nil
378 "The current testsuite.")
380 (defvar *lift-dribble-pathname
* nil
381 "If bound, then test output from run-tests will be sent to this file in
382 in addition to *lift-standard-output*. It can be set to nil or to a pathname.")
384 (defvar *lift-report-pathname
* nil
385 "If bound to a pathname or stream, then a summary of test information will
386 be written to it for later processing. It can be set to:
388 * `nil` - generate no output
389 * pathname designator - send output to this pathname
390 * `t` - send output to a pathname constructed from the name of the system
391 being tested (this only works if ASDF is being used to test the system).
393 As an example of the last case, if LIFT is testing a system named ...
396 (defvar *lift-standard-output
* *standard-output
*
397 "Output from tests will be sent to this stream. If can set to nil or
398 to an output stream. It defaults to *standard-output*.")
400 (defvar *lift-if-dribble-exists
* :append
401 "Specifies what to do to any existing file at *lift-dribble-pathname*. It
402 can be :supersede, :append, or :error.")
404 (defvar *test-show-expected-p
* t
)
406 (defvar *test-show-details-p
* t
)
408 (defvar *test-show-code-p
* t
)
410 ;;; ---------------------------------------------------------------------------
411 ;;; Error messages and warnings
412 ;;; ---------------------------------------------------------------------------
414 (defparameter +lift-test-name-not-supplied-with-test-class
+
415 "if you specify a test-class, you must also specify a test-name.")
417 (defparameter +lift-test-class-not-found
+
418 "test class '~S' not found.")
420 (defparameter +lift-confused-about-arguments
+
421 "I'm confused about what you said?!")
423 (defparameter +lift-no-current-test-class
+
424 "There is no current-test-class to use as a default.")
426 (defparameter +lift-could-not-find-test
+
427 "Could not find test: ~S.~S")
429 (defparameter +run-tests-null-test-case
+
430 "There is no current testsuite (possibly because
431 none have been defined yet?). You can specify the
432 testsuite to test by evaluating (run-tests :suite <suitename>).")
434 (defparameter +lift-unable-to-parse-test-name-and-class
+
438 ;;; ---------------------------------------------------------------------------
440 ;;; ---------------------------------------------------------------------------
442 (define-condition lift-compile-error
(error)
445 :initarg
:lift-message
))
446 (:report
(lambda (c s
)
447 (format s
"Compile error: '~S'" (msg c
)))))
449 (define-condition testsuite-not-defined
(lift-compile-error)
450 ((testsuite-name :reader testsuite-name
451 :initarg
:testsuite-name
))
452 (:report
(lambda (c s
)
453 (format s
"Test class ~A not defined before it was used."
454 (testsuite-name c
)))))
456 (define-condition test-case-not-defined
(lift-compile-error)
457 ((testsuite-name :reader testsuite-name
458 :initarg
:testsuite-name
)
459 (test-case-name :reader test-case-name
460 :initarg
:test-case-name
))
461 (:report
(lambda (c s
)
462 (format s
"Testsuite ~s has no test-case named ~s."
464 (test-case-name c
)))))
466 (define-condition test-condition
(warning)
467 ((message :initform
""
470 (:report
(lambda (c s
)
472 (format s
"~%~A" (message c
))))))
474 (define-condition test-timeout-condition
(test-condition)
475 ((maximum-time :initform
*test-maximum-time
*
476 :accessor maximum-time
477 :initarg
:maximum-time
))
478 (:report
(lambda (c s
)
479 (format s
"Test ran out of time (longer than ~S-second~:P)"
482 (define-condition ensure-failed-error
(test-condition)
483 ((assertion :initform
""
485 :initarg
:assertion
))
486 (:report
(lambda (c s
)
487 (format s
"Ensure failed: ~S ~@[(~a)~]"
488 (assertion c
) (message c
)))))
490 (define-condition ensure-null-failed-error
(ensure-failed-error)
494 (assertion :initform
""
496 :initarg
:assertion
))
497 (:report
(lambda (c s
)
498 (format s
"Ensure null failed: ~s evaluates to ~s ~@[(~a)~]"
499 (assertion c
) (value c
) (message c
)))))
501 (define-condition ensure-expected-condition
(test-condition)
502 ((expected-condition-type
504 :accessor expected-condition-type
505 :initarg
:expected-condition-type
)
508 :accessor the-condition
509 :initarg
:the-condition
))
510 (:report
(lambda (c s
)
511 (let ((the-condition (the-condition c
)))
512 (format s
"Expected ~S but got ~S~@[:~_ ~A~]"
513 (expected-condition-type c
)
514 (type-of the-condition
)
515 (and (typep the-condition
'condition
)
518 (define-condition ensure-expected-no-warning-condition
(test-condition)
521 :accessor the-condition
522 :initarg
:the-condition
))
523 (:report
(lambda (c s
)
524 (format s
"Expected no warnings but got ~S"
525 (the-condition c
)))))
527 (define-condition ensure-not-same
(test-condition)
528 ((first-value :accessor first-value
529 :initarg
:first-value
)
530 (second-value :accessor second-value
531 :initarg
:second-value
)
534 (:report
(lambda (c s
)
535 (format s
"Ensure-same: ~S is not ~S to ~S~@[ (~a)~]"
536 (first-value c
) (test c
) (second-value c
)
539 (define-condition ensure-cases-failure
(test-condition)
540 ((total :initarg
:total
:initform
0)
541 (problems :initarg
:problems
:initform nil
))
542 (:report
(lambda (condition stream
)
543 (format stream
"Ensure-cases: ~d out of ~d cases failed. Failing cases are: ~{~% ~{~s (~a)~}~^, ~}"
544 (length (slot-value condition
'problems
))
545 (slot-value condition
'total
)
546 (slot-value condition
'problems
)))))
548 (define-condition unexpected-success-failure
(test-condition)
549 ((expected :reader expected
:initarg
:expected
)
550 (expected-more :reader expected-more
:initarg
:expected-more
))
551 (:report
(lambda (c s
)
552 (format s
"Test succeeded but we expected ~s (~s)"
554 (expected-more c
)))))
556 (defun build-lift-error-message (context message
&rest arguments
)
559 (apply #'format nil message arguments
)))
561 (defun signal-lift-error (context message
&rest arguments
)
562 (let ((c (make-condition
564 :lift-message
(apply #'build-lift-error-message
565 context message arguments
))))
569 (defun report-lift-error (context message
&rest arguments
)
570 (format *debug-io
* "~&~A."
571 (apply #'build-lift-error-message context message arguments
))
574 (defun lift-report-condition (c)
575 (format *debug-io
* "~&~A." c
))
577 (defmacro ensure
(predicate &key report arguments
)
578 "If ensure's `predicate` evaluates to false, then it will generate a
579 test failure. You can use the `report` and `arguments` keyword parameters
580 to customize the report generated in test results. For example:
583 :report \"I hope ~a does not = ~a\"
586 will generate a message like
588 Warning: Ensure failed: (= 23 12) (I hope 12 does not = 23)
590 (let ((gpredicate (gensym)))
591 `(let ((,gpredicate
,predicate
))
594 (let ((condition (make-condition
596 :assertion
',predicate
599 (format nil
,report
,@arguments
))))))
600 (if (find-restart 'ensure-failed
)
601 (invoke-restart 'ensure-failed condition
)
602 (warn condition
)))))))
604 (defmacro ensure-null
(predicate &key report arguments
)
605 "If ensure-null's `predicate` evaluates to true, then it will generate a
606 test failure. You can use the `report` and `arguments` keyword parameters
607 to customize the report generated in test results. See [ensure][] for more
610 `(let ((,g
,predicate
))
613 (let ((condition (make-condition 'ensure-null-failed-error
615 :assertion
',predicate
617 `(:message
(format nil
,report
,@arguments
))))))
618 (if (find-restart 'ensure-failed
)
619 (invoke-restart 'ensure-failed condition
)
620 (warn condition
)))))))
622 (defmacro ensure-condition
(condition &body body
)
623 "This macro is used to make sure that body really does produce condition."
624 (setf condition
(remove-leading-quote condition
))
625 (destructuring-bind (condition &key report arguments
)
626 (if (consp condition
) condition
(list condition
))
633 (declare (ignore cond
)) (setf ,g t
))
636 (let ((c (make-condition
637 'ensure-expected-condition
638 :expected-condition-type
',condition
642 (format nil
,report
,arguments
))))))
643 (if (find-restart 'ensure-failed
)
644 (invoke-restart 'ensure-failed c
)
647 (if (find-restart 'ensure-failed
)
651 'ensure-expected-condition
652 :expected-condition-type
',condition
655 `(:message
(format nil
,report
,arguments
)))))
656 (warn "Ensure-condition didn't get the condition it expected."))))))))
658 (defmacro ensure-no-warning
(&body body
)
659 "This macro is used to make sure that body produces no warning."
661 (gcondition (gensym)))
668 (setf ,gcondition c
,g t
)))
670 (let ((c (make-condition
671 'ensure-expected-no-warning-condition
672 :the-condition
,gcondition
)))
673 (if (find-restart 'ensure-failed
)
674 (invoke-restart 'ensure-failed c
)
677 (defmacro ensure-warning
(&body body
)
678 "Ensure-warning evaluates its body. If the body does *not* signal a
679 warning, then ensure-warning will generate a test failure."
680 `(ensure-condition warning
,@body
))
682 (defmacro ensure-error
(&body body
)
683 "Ensure-error evaluates its body. If the body does *not* signal an
684 error, then ensure-error will generate a test failure."
685 `(ensure-condition error
,@body
))
687 (defmacro ensure-same
688 (form values
&key
(test nil test-specified-p
)
689 (report nil
) (arguments nil
))
690 "Ensure same compares value-or-values-1 value-or-values-2 or each value of value-or-values-1 value-or-values-2 (if they are multiple values) using test. If a problem is encountered ensure-same raises a warning which uses report as a format string and arguments as arguments to that string (if report and arguments are supplied). If ensure-same is used within a test, a test failure is generated instead of a warning"
691 (setf test
(remove-leading-quote test
))
692 (when (and (consp test
)
693 (eq (first test
) 'function
))
694 (setf test
(second test
)))
695 (let ((block (gensym)))
697 (loop for value in
(multiple-value-list ,form
)
698 for other-value in
(multiple-value-list ,values
) do
699 (unless (funcall ,(if test-specified-p
(list 'quote test
)
700 '*lift-equality-test
*)
702 (maybe-raise-not-same-condition
704 ,(if test-specified-p
(list 'quote test
) '*lift-equality-test
*)
706 (return-from ,block nil
)))
709 (defmacro ensure-different
710 (form values
&key
(test nil test-specified-p
)
711 (report nil
) (arguments nil
))
712 "Ensure-different compares value-or-values-1 value-or-values-2 or each value of value-or-values-1 and value-or-values-2 (if they are multiple values) using test. If any comparison returns true, then ensure-different raises a warning which uses report as a format string and `arguments` as arguments to that string (if report and `arguments` are supplied). If ensure-different is used within a test, a test failure is generated instead of a warning"
713 ;; FIXME -- share code with ensure-same
714 (setf test
(remove-leading-quote test
))
715 (when (and (consp test
)
716 (eq (first test
) 'function
))
717 (setf test
(second test
)))
719 (loop for value in
(multiple-value-list ,form
)
720 for other-value in
(multiple-value-list ,values
) do
721 ;; WHEN instead of UNLESS
722 (when (funcall ,(if test-specified-p
724 '*lift-equality-test
*)
726 (maybe-raise-not-same-condition
728 ,(if test-specified-p
730 '*lift-equality-test
*) ,report
,@arguments
)))
733 (defun maybe-raise-not-same-condition (value-1 value-2 test
734 report
&rest arguments
)
735 (let ((condition (make-condition 'ensure-not-same
737 :second-value value-2
739 :message
(when report
741 report arguments
)))))
742 (if (find-restart 'ensure-failed
)
743 (invoke-restart 'ensure-failed condition
)
746 (defmacro ensure-cases
((&rest vars
) (&rest cases
) &body body
)
747 (let ((case (gensym))
750 `(let ((,problems nil
) (,total
0))
751 (loop for
,case in
,cases do
753 (destructuring-bind ,vars
,case
756 (ensure-failed (cond)
757 (push (list ,case cond
) ,problems
)))))
759 (let ((condition (make-condition
760 'ensure-cases-failure
762 :problems
,problems
)))
763 (if (find-restart 'ensure-failed
)
764 (invoke-restart 'ensure-failed condition
)
765 (warn condition
)))))))
768 ;;; ---------------------------------------------------------------------------
770 ;;; ---------------------------------------------------------------------------
772 (defclass test-mixin
()
773 ((name :initform nil
:initarg
:name
:accessor name
:reader testsuite-name
)
774 (run-setup :reader run-setup
:initarg
:run-setup
)
775 (done-setup?
:initform nil
:reader done-setup?
)
776 (done-dynamics?
:initform nil
:reader done-dynamics?
)
777 (prototypes :initform
(list (list)) :accessor prototypes
)
778 (prototypes-initialized?
:initform nil
:reader prototypes-initialized?
)
779 (current-values :initform nil
:accessor current-values
)
780 (test-slot-names :initform nil
:initarg
:test-slot-names
781 :reader test-slot-names
)
782 (current-step :initform
:created
:accessor current-step
)
783 (current-method :initform nil
:accessor current-method
)
784 (save-equality-test :initform nil
:reader save-equality-test
)
785 (log-file :initform nil
:initarg
:log-file
:reader log-file
)
786 (test-data :initform nil
:accessor test-data
)
787 (expected-failure-p :initform nil
:initarg
:expected-failure-p
788 :reader expected-failure-p
)
789 (expected-error-p :initform nil
:initarg
:expected-error-p
790 :reader expected-error-p
)
791 (expected-problem-p :initform nil
:initarg
:expected-problem-p
792 :reader expected-problem-p
)
795 :accessor suite-initargs
)
799 (:documentation
"A test suite")
801 :run-setup
:once-per-test-case
))
803 (defmethod equality-test ((suite test-mixin
))
806 (defclass test-result
()
807 ((results-for :initform nil
808 :initarg
:results-for
809 :accessor results-for
)
810 (tests-run :initform nil
:accessor tests-run
)
811 (suites-run :initform nil
:accessor suites-run
)
812 (failures :initform nil
:accessor failures
)
813 (expected-failures :initform nil
:accessor expected-failures
)
814 (errors :initform nil
:accessor errors
)
815 (expected-errors :initform nil
:accessor expected-errors
)
816 (test-mode :initform
:single
:initarg
:test-mode
:accessor test-mode
)
817 (test-interactive?
:initform nil
818 :initarg
:test-interactive?
:accessor test-interactive?
)
819 (real-start-time :initarg
:real-start-time
:reader real-start-time
)
820 (start-time :accessor start-time
:initform nil
)
821 (end-time :accessor end-time
)
822 (real-end-time :accessor real-end-time
)
823 (real-start-time-universal
824 :initarg
:real-start-time-universal
:reader real-start-time-universal
)
825 (start-time-universal :accessor start-time-universal
:initform nil
)
826 (end-time-universal :accessor end-time-universal
)
827 (real-end-time-universal :accessor real-end-time-universal
)
828 (properties :initform nil
:accessor test-result-properties
)
829 (tests-to-skip :initform nil
830 :initarg
:tests-to-skip
831 :reader tests-to-skip
832 :writer %set-tests-to-skip
))
834 :test-interactive?
*test-is-being-defined?
*
835 :real-start-time
(get-internal-real-time)
836 :real-start-time-universal
(get-universal-time)
837 :tests-to-skip
*lift-tests-to-skip
*))
839 (defmethod initialize-instance :after
840 ((result test-result
) &key tests-to-skip
)
843 (mapcar (lambda (datum)
844 (cond ((or (atom datum
)
845 (= (length datum
) 1))
846 (cons (find-testsuite datum
) nil
))
847 ((= (length datum
) 2)
848 (cons (find-testsuite (first datum
))
849 (or (and (keywordp (second datum
)) (second datum
))
850 (find-test-case (find-testsuite (first datum
))
853 (warn "Unable to interpret skip datum ~a. Ignoring."
858 (defun test-result-property (result property
&optional default
)
859 (getf (test-result-properties result
) property default
))
861 (defun (setf test-result-property
) (value result property
)
862 (setf (getf (test-result-properties result
) property
) value
))
864 (defun print-lift-message (message &rest args
)
865 (apply #'format
*lift-debug-output
* message args
)
866 (force-output *lift-debug-output
*))
868 (defgeneric testsuite-setup
(testsuite result
)
869 (:documentation
"Setup at the testsuite-level")
870 (:method
((testsuite test-mixin
) (result test-result
))
872 (:method
:before
((testsuite test-mixin
) (result test-result
))
873 (when (and *test-print-testsuite-names
*
874 (eq (test-mode result
) :multiple
))
875 (print-lift-message "~&Start: ~a" (type-of testsuite
)))
876 (push (type-of testsuite
) (suites-run result
))
877 (setf (current-step testsuite
) :testsuite-setup
)))
879 (defgeneric testsuite-expects-error
(testsuite)
880 (:documentation
"Returns whether or not the testsuite as a whole expects an error.")
881 (:method
((testsuite test-mixin
))
884 (defgeneric testsuite-expects-failure
(testsuite)
885 (:documentation
"Returns whether or not the testsuite as a whole expects to fail.")
886 (:method
((testsuite test-mixin
))
889 (defgeneric testsuite-run
(testsuite result
)
890 (:documentation
"Run the cases in this suite and it's children."))
892 (defgeneric testsuite-teardown
(testsuite result
)
893 (:documentation
"Cleanup at the testsuite level.")
894 (:method
((testsuite test-mixin
) (result test-result
))
897 (:method
:after
((testsuite test-mixin
) (result test-result
))
898 (setf (current-step testsuite
) :testsuite-teardown
899 (real-end-time result
) (get-internal-real-time)
900 (real-end-time-universal result
) (get-universal-time))))
902 (defgeneric more-prototypes-p
(testsuite)
903 (:documentation
"Returns true if another prototype set exists for the case."))
905 (defgeneric initialize-prototypes
(testsuite)
906 (:documentation
"Creates lists of all prototype sets."))
908 (defgeneric next-prototype
(testsuite)
909 (:documentation
"Ensures that the test environment has the values of the next prototype set."))
911 (defgeneric make-single-prototype
(testsuite))
913 (defgeneric setup-test
(testsuite)
914 (:documentation
"Setup for a test-case. By default it does nothing."))
916 (defgeneric teardown-test
(testsuite)
917 (:documentation
"Tear-down a test-case. By default it does nothing.")
918 (:method-combination progn
:most-specific-first
))
920 (defgeneric testsuite-methods
(testsuite)
921 (:documentation
"Returns a list of the test methods defined for test. I.e.,
922 the methods that should be run to do the tests for this test."))
924 (defgeneric lift-test
(suite name
)
927 (defgeneric do-testing
(testsuite result fn
)
930 (defgeneric end-test
(result case method-name
)
933 (defgeneric initialize-test
(test)
936 (defgeneric run-test-internal
(suite name result
)
939 (defgeneric run-tests-internal
(suite &key result
)
942 (defgeneric start-test
(result case method-name
)
945 (defgeneric test-report-code
(testsuite method
)
948 (defgeneric testsuite-p
(thing)
949 (:documentation
"Determine whether or not `thing` is a testsuite. Thing can be a symbol naming a suite, a subclass of `test-mixin` or an instance of a test suite. Returns nil if `thing` is not a testsuite and the symbol naming the suite if it is."))
951 (defgeneric testsuite-name-
>gf
(case name
)
954 (defgeneric testsuite-name-
>method
(class name
)
957 (defgeneric flet-test-function
(testsuite function-name
&rest args
)
960 (defmethod setup-test :before
((test test-mixin
))
961 (setf *test-scratchpad
* nil
962 (current-step test
) :test-setup
))
964 (defmethod setup-test ((test test-mixin
))
967 (defmethod teardown-test progn
((test test-mixin
))
970 (defmethod teardown-test :around
((test test-mixin
))
971 (setf (current-step test
) :test-teardown
)
974 (defmethod initialize-test ((test test-mixin
))
977 (defmethod initialize-test :before
((test test-mixin
))
979 (initialize-prototypes test
)
980 (next-prototype test
))
982 (defmethod initialize-instance :after
((testsuite test-mixin
) &rest initargs
983 &key
&allow-other-keys
)
984 (when (null (testsuite-name testsuite
))
985 (setf (slot-value testsuite
'name
)
986 (symbol-name (type-of testsuite
))))
987 ;; FIXME - maybe remove LIFT standard arguments?
988 (setf (suite-initargs testsuite
) initargs
))
990 (defmethod print-object ((tc test-mixin
) stream
)
991 (print-unreadable-object (tc stream
:identity t
:type t
)
992 (format stream
"~a" (testsuite-name tc
))))
994 ;;; ---------------------------------------------------------------------------
996 ;;; ---------------------------------------------------------------------------
998 (defvar *current-definition
* nil
999 "An associative-container which saves interesting information about
1000 the thing being defined.")
1002 (defun initialize-current-definition ()
1003 (setf *current-definition
* nil
))
1005 (defun set-definition (name value
)
1006 (let ((current (assoc name
*current-definition
*)))
1008 (setf (cdr current
) value
)
1009 (push (cons name value
) *current-definition
*)))
1013 (defun def (name &optional
(definition *current-definition
*))
1014 (when definition
(cdr (assoc name definition
))))
1016 (defun (setf def
) (value name
)
1017 (set-definition name value
))
1019 (defvar *code-blocks
* nil
)
1021 (defstruct (code-block (:type list
) (:conc-name nil
))
1022 block-name
(priority 0) filter code operate-when
)
1024 (defgeneric block-handler
(name value
)
1026 (:method
((name t
) (value t
))
1027 (error "Unknown clause: ~A" name
)))
1029 (defun add-code-block (name priority operate-when filter handler code
)
1030 (let ((current (assoc name
*code-blocks
*))
1031 (value (make-code-block
1032 :operate-when operate-when
1038 (setf (cdr current
) value
)
1039 (push (cons name value
) *code-blocks
*))
1041 `(defmethod block-handler ((name (eql ',name
)) value
)
1042 (declare (ignorable value
))
1044 (setf *code-blocks
* (sort *code-blocks
* #'<
1045 :key
(lambda (name.cb
)
1046 (priority (cdr name.cb
))))))
1048 (defmacro with-test-slots
(&body body
)
1049 `(symbol-macrolet ((lift-result (getf (test-data *current-test
*) :result
)))
1050 ;; case111 - LW complains otherwise
1051 (declare (ignorable lift-result
))
1053 ,(mapcar #'(lambda (local)
1054 `(,local
(test-environment-value ',local
)))
1055 (test-slots (def :testsuite-name
)))
1056 (declare (ignorable ,@(test-slots (def :testsuite-name
))))
1058 ,(mapcar (lambda (spec)
1059 (destructuring-bind (name arglist
) spec
1061 `(flet-test-function
1062 *current-test
* ',',name
,,@arglist
))))
1063 (def :function-specs
))
1066 (defvar *deftest-clauses
*
1067 '(:setup
:teardown
:test
:documentation
:tests
:export-p
:export-slots
1068 :run-setup
:dynamic-variables
:equality-test
:categories
:function
))
1070 (defmacro deftest
(testsuite-name superclasses slots
&rest
1071 clauses-and-options
)
1072 "The `deftest` form is obsolete, see [deftestsuite][]."
1074 (warn "Deftest is obsolete, use deftestsuite instead.")
1075 `(deftestsuite ,testsuite-name
,superclasses
,slots
,@clauses-and-options
))
1077 (setf *code-blocks
* nil
)
1081 (lambda () (or (def :setup
) (def :direct-slot-names
)))
1082 '((setf (def :setup
) (cleanup-parsed-parameter value
)))
1083 'build-setup-test-method
)
1086 :teardown
100 :methods
1087 (lambda () (or (def :teardown
) (def :direct-slot-names
)))
1088 '((setf (def :teardown
) (cleanup-parsed-parameter value
)))
1089 'build-test-teardown-method
)
1092 :function
0 :methods
1093 (lambda () (def :functions
))
1094 '((push value
(def :functions
)))
1095 'build-test-local-functions
)
1098 :documentation
0 :class-def
1100 '((setf (def :documentation
) (first value
)))
1104 :export-p
0 :class-def
1106 '((setf (def :export-p
) (first value
)))
1110 :export-slots
0 :class-def
1112 '((setf (def :export-slots
) (first value
)))
1116 :run-setup
0 :class-def
1118 '((push (first value
) (def :default-initargs
))
1119 (push :run-setup
(def :default-initargs
))
1120 (setf (def :run-setup
) (first value
)))
1124 :equality-test
0 :methods
1125 (lambda () (def :equality-test
))
1126 '((setf (def :equality-test
) (cleanup-parsed-parameter value
)))
1127 'build-test-equality-test
)
1130 :expected-error
0 :methods
1131 (lambda () (def :expected-error
))
1132 '((setf (def :expected-error
) (cleanup-parsed-parameter value
)))
1133 'build-testsuite-expected-error
)
1136 :expected-failure
0 :methods
1137 (lambda () (def :expected-failure
))
1138 '((setf (def :expected-failure
) (cleanup-parsed-parameter value
)))
1139 'build-testsuite-expected-failure
)
1142 :log-file
0 :class-def
1144 '((push (first value
) (def :default-initargs
))
1145 (push :log-file
(def :default-initargs
)))
1149 :dynamic-variables
0 :class-def
1151 '((setf (def :direct-dynamic-variables
) value
))
1155 :categories
0 :class-def
1157 '((push value
(def :categories
)))
1161 :default-initargs
1 :class-def
1162 (lambda () (def :default-initargs
))
1163 '((dolist (x (reverse (cleanup-parsed-parameter value
)))
1164 (push x
(def :default-initargs
))))
1167 (defmacro deftestsuite
(testsuite-name superclasses slots
&rest
1168 clauses-and-options
)
1170 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.
1172 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.
1174 Slots are specified as in defclass with the following additions:
1176 * 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)`.
1177 * 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
1179 (deftestsuite my-test ()
1182 then `my-slot` will be initialized to 23 during test setup.
1184 Test options are one of :setup, :teardown, :test, :tests, :documentation, :export-p, :dynamic-variables, :export-slots, :function, :categories, :run-setup, or :equality-test.
1186 * :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.
1188 * :documentation - a string specifying any documentation for the test. Should only be specified once.
1190 * :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.
1192 * :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.
1194 * :export-p - If true, the testsuite name will be exported from the current package. Should only be specified once.
1196 * :export-slots - if true, any slots specified in the test suite will be exported from the current package. Should only be specified once.
1198 * :function - creates a locally accessible function for this test suite. May be specified multiple times.
1200 * :run-setup - specify when to run the setup code for this test suite. Allowed values are
1202 * :once-per-test-case or t (the default)
1207 :run-setup is handy when a testsuite has a time consuming setup phase that you do not want to repeat for every test.
1209 * :setup - a list of forms to be evaluated before each test case is run. Should only be specified once.
1211 * :teardown - a list of forms to be evaluated after each test case is run. Should only be specified once.
1213 * :test - Define a single test case. Can be specified multiple times.
1215 * :tests - Define multiple test cases for this test suite. Can be specified multiple times.
1220 (let ((test-list nil
)
1223 ;; convert any clause like :setup foo into (:setup foo)
1224 (setf clauses-and-options
1225 (convert-clauses-into-lists clauses-and-options
*deftest-clauses
*))
1226 (initialize-current-definition)
1227 (setf (def :testsuite-name
) testsuite-name
)
1228 (setf (def :superclasses
) (mapcar #'find-testsuite superclasses
))
1229 (setf (def :deftestsuite
) t
)
1230 ;; parse clauses into defs
1231 (loop for clause in clauses-and-options do
1233 (symbol (pushnew clause options
))
1234 (cons (destructuring-bind (kind &rest spec
) clause
1236 (:test
(push (first spec
) test-list
))
1238 (loop for test in spec do
1239 (push test test-list
)))
1240 (t (block-handler kind spec
)))))
1241 (t (error "When parsing ~S" clause
))))
1242 (let ((slot-names nil
) (slot-specs nil
))
1243 (loop for slot in
(if (listp slots
) slots
(list slots
)) do
1244 (push (if (consp slot
) (first slot
) slot
) slot-names
)
1245 (push (parse-brief-slot slot nil nil nil nil
) slot-specs
))
1246 (setf (def :slot-specs
) (nreverse slot-specs
)
1247 (def :direct-slot-names
) (nreverse slot-names
)
1248 (def :slots-parsed
) t
))
1249 ;;?? issue 27: breaks 'encapsulation' of code-block mechanism
1250 (setf (def :function-specs
)
1251 (loop for spec in
(def :functions
) collect
1252 (destructuring-bind (name arglist
&body body
) (first spec
)
1253 (declare (ignore body
))
1254 `(,name
,arglist
))))
1256 (empty-test-tables testsuite-name
)
1257 (compute-superclass-inheritence)
1259 (setf *testsuite-test-count
* 0)
1260 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
1261 (eval-when (:compile-toplevel
)
1262 (push ',return
*test-is-being-compiled?
*))
1263 (eval-when (:load-toplevel
)
1264 (push ',return
*test-is-being-loaded?
*))
1265 (eval-when (:execute
)
1266 (push ',return
*test-is-being-executed?
*))
1267 ;; remove previous methods (do this _before_ we define the class)
1268 (unless (or *test-is-being-compiled?
*
1269 *test-is-being-loaded?
*)
1271 (print (list :cle
*test-is-being-compiled?
*
1272 *test-is-being-loaded?
*
1273 *test-is-being-loaded?
*))
1274 (remove-previous-definitions ',(def :testsuite-name
)))
1277 (let ((*test-is-being-defined?
* t
))
1278 (setf *current-test-case-name
* nil
)
1279 (setf *current-testsuite-name
* ',(def :testsuite-name
)
1280 (test-slots ',(def :testsuite-name
))
1282 (testsuite-dynamic-variables ',(def :testsuite-name
))
1283 ',(def :dynamic-variables
)
1284 ;;?? issue 27: breaks 'encapsulation' of code-block
1286 (testsuite-function-specs ',(def :testsuite-name
))
1287 ',(def :function-specs
))
1288 ,@(when (def :export-p
)
1289 `((export '(,(def :testsuite-name
)))))
1290 ,@(when (def :export-slots?
)
1291 `((export ',(def :direct-slot-names
))))
1292 ;; make a place to save test-case information
1293 (empty-test-tables ',(def :testsuite-name
))
1296 ,@(build-initialize-test-method)
1297 ,@(loop for
(nil . block
) in
*code-blocks
*
1300 (eq (operate-when block
) :methods
)
1301 (or (not (filter block
))
1302 (funcall (filter block
)))) collect
1303 (funcall (code block
)))
1304 ,@(when (def :dynamic-variables
)
1305 `((defmethod do-testing :around
1306 ((suite ,(def :testsuite-name
)) result fn
)
1307 (declare (ignore result fn
))
1308 (cond ((done-dynamics? suite
)
1311 (setf (slot-value suite
'done-dynamics?
) t
)
1312 (let* (,@(build-dynamics))
1313 (call-next-method)))))))
1316 `((let ((*test-evaluate-when-defined?
* nil
))
1317 ,@(loop for test in
(nreverse test-list
) collect
1318 `(addtest (,(def :testsuite-name
))
1320 (setf *testsuite-test-count
* nil
))))
1321 ,(if (and test-list
*test-evaluate-when-defined?
*)
1322 `(unless (or *test-is-being-compiled?
*
1323 *test-is-being-loaded?
*)
1324 (let ((*test-break-on-errors?
* *test-break-on-errors?
*))
1325 (run-tests :suite
',testsuite-name
)))
1326 `(find-class ',testsuite-name
)))
1328 (setf *test-is-being-compiled?
*
1329 (remove ',return
*test-is-being-compiled?
*))
1330 (setf *test-is-being-loaded?
*
1331 (remove ',return
*test-is-being-loaded?
*))
1332 (setf *test-is-being-executed?
*
1333 (remove ',return
*test-is-being-executed?
*)))))))
1335 (defun compute-superclass-inheritence ()
1336 ;;?? issue 27: break encapsulation of code blocks
1337 ;;?? we assume that we won't have too deep a hierarchy or too many
1338 ;; dv's or functions so that having lots of duplicate names is OK
1340 (dynamic-variables nil
)
1341 (function-specs nil
))
1342 (dolist (super (def :superclasses
))
1343 (cond ((find-testsuite super
)
1344 (setf slots
(append slots
(test-slots super
))
1346 (append dynamic-variables
1347 (testsuite-dynamic-variables super
))
1349 (append function-specs
1350 (testsuite-function-specs super
))))
1352 (error 'testsuite-not-defined
:testsuite-name super
))))
1353 (setf (def :slot-names
)
1354 (remove-duplicates (append (def :direct-slot-names
) slots
))
1355 (def :dynamic-variables
)
1357 (append (def :direct-dynamic-variables
) dynamic-variables
))
1358 (def :function-specs
)
1360 (append (def :function-specs
) function-specs
)))
1361 (setf (def :superclasses
)
1362 (loop for class in
(def :superclasses
)
1363 unless
(some (lambda (oter)
1364 (and (not (eq class oter
))
1365 (member class
(superclasses oter
))))
1366 (def :superclasses
)) collect
1369 (defmacro addtest
(name &body test
)
1370 "Adds a single new test-case to the most recently defined testsuite."
1377 (looks-like-suite-name (looks-like-suite-name-p name
))
1378 (looks-like-code (looks-like-code-p name
)))
1379 (cond ((and looks-like-suite-name looks-like-code
)
1380 (error "Can't disambiguate suite name from possible code."))
1381 (looks-like-suite-name
1383 (setf (def :testsuite-name
) (first name
)
1385 name nil body test
))
1387 ;; the 'name' is really part of the test...
1388 (setf body
(cons name test
))))
1389 (unless (def :testsuite-name
)
1390 (when *current-testsuite-name
*
1391 (setf (def :testsuite-name
) *current-testsuite-name
*)))
1392 (unless (def :testsuite-name
)
1393 (signal-lift-error 'add-test
+lift-no-current-test-class
+))
1394 (unless (or (def :deftestsuite
)
1395 (find-testsuite (def :testsuite-name
)))
1396 (signal-lift-error 'add-test
+lift-test-class-not-found
+
1397 (def :testsuite-name
)))
1398 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
1399 (eval-when (:compile-toplevel
)
1400 (push ',return
*test-is-being-compiled?
*))
1401 (eval-when (:load-toplevel
)
1402 (push ',return
*test-is-being-loaded?
*))
1403 (eval-when (:execute
)
1404 (push ',return
*test-is-being-executed?
*))
1406 (let ((*test-is-being-defined?
* t
))
1407 ,(build-test-test-method (def :testsuite-name
) body options
)
1408 (setf *current-testsuite-name
* ',(def :testsuite-name
))
1409 (if *test-evaluate-when-defined?
*
1410 (unless (or *test-is-being-compiled?
*
1411 *test-is-being-loaded?
*)
1412 (let ((*test-break-on-errors?
* (testing-interactively-p)))
1416 (setf *test-is-being-compiled?
*
1417 (remove ',return
*test-is-being-compiled?
*)
1418 *test-is-being-loaded?
*
1419 (remove ',return
*test-is-being-loaded?
*)
1420 *test-is-being-executed?
*
1421 (remove ',return
*test-is-being-executed?
*))))))
1423 (defun looks-like-suite-name-p (form)
1426 (find-testsuite (first form
))
1427 (property-list-p (rest form
))))
1429 (defun property-list-p (form)
1434 for want-keyword?
= t then
(not want-keyword?
) do
1435 (when (and want-keyword?
(not (keywordp x
)))
1436 (return-from check-it nil
))
1437 (setf even?
(not even?
)))
1438 (return-from check-it even?
)))))
1441 (property-list-p '(:a
:b
))
1442 (property-list-p '(:a
2 :b
3 :c
5 :d
8))
1443 (property-list-p nil
)
1446 (property-list-p '(3))
1447 (property-list-p '(3 :a
))
1448 (property-list-p '(:a
3 :b
))
1451 (defun looks-like-code-p (name)
1452 (declare (ignore name
))
1456 (defun remove-test (&key
(test-case *current-test-case-name
*)
1457 (suite *current-testsuite-name
*))
1458 (assert suite nil
"Test suite could not be determined.")
1459 (assert test-case nil
"Test-case could not be determined.")
1460 (setf (testsuite-tests suite
)
1461 (remove test-case
(testsuite-tests suite
))))
1463 (defun run-test (&rest args
1464 &key
(test-case *current-test-case-name
*)
1465 (name test-case name-supplied-p
)
1466 (suite *current-testsuite-name
*)
1467 (break-on-errors?
*test-break-on-errors?
*)
1468 (break-on-failures?
*test-break-on-failures?
*)
1469 (do-children?
*test-do-children?
*)
1472 "Run a single testcase in a test suite. Will run the most recently defined or run testcase unless the name and suite arguments are used to override them."
1473 (declare (ignore profile
))
1474 (when name-supplied-p
1475 (setf test-case name
))
1476 (assert suite nil
"Test suite could not be determined.")
1477 (assert test-case nil
"Test-case could not be determined.")
1478 (let* ((*test-break-on-errors?
* break-on-errors?
)
1479 (*test-break-on-failures?
* break-on-failures?
)
1480 (*test-do-children?
* do-children?
)
1481 (*current-test
* (make-testsuite suite args
)))
1483 (setf result
(make-test-result suite
:single
)))
1485 (let ((*current-test-case-name
* (find-test-case suite test-case
))
1486 (*current-testsuite-name
* suite
))
1487 (do-testing-in-environment
1488 *current-test
* result
1491 *current-test
* *current-test-case-name
* result
)))
1492 (setf *test-result
* result
))
1493 (setf *current-test-case-name
* (find-test-case suite test-case
)
1494 *current-testsuite-name
* suite
))))
1496 (defun make-testsuite (suite args
)
1497 (let ((make-instance-args nil
))
1498 (loop for keyword in
*make-testsuite-arguments
* do
1499 (when (member keyword args
)
1500 (push keyword make-instance-args
)
1501 (push (getf args keyword
) make-instance-args
)))
1502 (apply #'make-instance
(find-testsuite suite
)
1503 (nreverse make-instance-args
))))
1506 (defmethod do-testing-in-environment :around
((suite test-mixin
) result fn
)
1507 (declare (ignore fn
))
1508 (testsuite-setup suite result
)
1513 ((not (more-prototypes-p suite
)) result
)
1515 (handler-bind ((warning #'muffle-warning
)
1516 ; ignore warnings...
1519 (report-test-problem
1520 'testsuite-error result suite
1521 *current-test-case-name
* condition
1522 :backtrace
(get-backtrace condition
))
1523 (if *test-break-on-errors?
*
1524 (invoke-debugger condition
)
1526 (let ((*lift-equality-test
* (equality-test suite
)))
1527 (initialize-test suite
)
1528 (call-next-method)))
1529 (ensure-failed (condition)
1530 (report-test-problem
1531 'testsuite-failure result suite
1532 *current-test-case-name
* condition
))
1533 (retry-test () :report
"Retry the test."
1537 (testsuite-teardown suite result
))
1540 (defmethod do-testing-in-environment :around
((suite test-mixin
) result fn
)
1541 (declare (ignore fn
))
1545 (handler-bind ((warning #'muffle-warning
)
1546 ; ignore warnings...
1549 (report-test-problem
1550 'testsuite-error result suite
1551 *current-test-case-name
* condition
1552 :backtrace
(get-backtrace condition
))
1553 (if *test-break-on-errors?
*
1554 (invoke-debugger condition
)
1557 (let ((*lift-equality-test
* (equality-test suite
)))
1558 (testsuite-setup suite result
)
1560 ((not (more-prototypes-p suite
)) result
)
1561 (initialize-test suite
)
1562 (call-next-method)))
1564 (testsuite-teardown suite result
)))
1565 (ensure-failed (condition)
1566 (report-test-problem
1567 'testsuite-failure result suite
1568 *current-test-case-name
* condition
))
1569 (retry-test () :report
"Retry the test."
1574 (defmethod do-testing-in-environment ((suite test-mixin
) result fn
)
1575 (do-testing suite result fn
)
1578 (defmethod do-testing ((suite test-mixin
) result fn
)
1582 (defmethod run-tests-internal ((suite symbol
) &rest args
&key
&allow-other-keys
)
1583 (let ((*current-test
* (make-testsuite suite args
)))
1584 (remf args
:profile
)
1585 (apply #'run-tests-internal
*current-test
* args
)))
1587 (defmethod run-tests-internal
1588 ((case test-mixin
) &key
1589 (result (make-test-result (class-of case
) :multiple
))
1590 (do-children?
*test-do-children?
*))
1591 (let ((*test-do-children?
* do-children?
))
1592 (do-testing-in-environment
1595 (testsuite-run case result
)))
1596 (setf *test-result
* result
)))
1598 (defun run-tests (&rest args
&key
1600 (break-on-errors?
*test-break-on-errors?
*)
1601 (break-on-failures?
*test-break-on-failures?
*)
1603 (dribble *lift-dribble-pathname
*)
1606 (do-children?
*test-do-children?
*)
1609 "Run all of the tests in a suite. Arguments are :suite, :result,
1610 :do-children? and :break-on-errors?"
1611 (let ((args-copy (copy-list args
)))
1613 (remf args
:break-on-errors?
)
1614 (remf args
:break-on-failures?
)
1615 (remf args
:run-setup
)
1616 (remf args
:dribble
)
1618 (remf args
:report-pathname
)
1619 (remf args
:do-children?
)
1620 (remf args
:tests-to-skip
)
1621 (let* ((result (or result
1622 (apply #'make-test-result
1623 (or suite config
) :multiple args
)))
1624 (*lift-report-pathname
*
1625 (cond ((null report-pathname
) nil
)
1626 ((eq report-pathname t
)
1627 (report-summary-pathname))))
1628 (*test-do-children?
* do-children?
)
1629 (report-pathname *lift-report-pathname
*))
1630 (when report-pathname
1631 (ensure-directories-exist report-pathname
)
1632 (write-report-header report-pathname result args-copy
))
1633 (cond ((and suite config
)
1634 (error "Specify either configuration file or test suite
1637 (run-tests-from-file config
))
1638 ((or suite
(setf suite
*current-testsuite-name
*))
1639 (let* ((*test-break-on-errors?
* break-on-errors?
)
1640 (*test-break-on-failures?
* break-on-failures?
)
1645 :if-does-not-exist
:create
1646 :if-exists
*lift-if-dribble-exists
*)))
1647 (*standard-output
* (maybe-add-dribble
1648 *lift-standard-output
* dribble-stream
))
1649 (*error-output
* (maybe-add-dribble
1650 *error-output
* dribble-stream
))
1651 (*debug-io
* (maybe-add-dribble
1652 *debug-io
* dribble-stream
)))
1654 (dolist (testsuite (if (consp suite
) suite
(list suite
)))
1655 (let ((*current-testsuite-name
* testsuite
))
1656 (apply #'run-tests-internal testsuite
1657 :result result
:profile profile args
))
1658 (setf *current-testsuite-name
* testsuite
))
1660 (when dribble-stream
1661 (close dribble-stream
)))
1663 (setf (tests-run result
) (reverse (tests-run result
)))
1664 (when report-pathname
1665 (write-report-footer report-pathname result
))
1668 (error "There is not a current test suite and neither suite
1669 nor configuration file options were specified."))))))
1671 (defun maybe-add-dribble (stream dribble-stream
)
1673 (values (make-broadcast-stream stream dribble-stream
) t
)
1674 (values stream nil
)))
1676 (defun skip-test-case-p (result suite-name test-case-name
)
1677 (find-if (lambda (skip-datum)
1678 (and (eq suite-name
(car skip-datum
))
1679 (or (null (cdr skip-datum
))
1680 (eq test-case-name
(cdr skip-datum
)))))
1681 (tests-to-skip result
)))
1683 (defmethod skip-test-case (result suite-name test-case-name
)
1684 (declare (ignore result suite-name test-case-name
))
1687 (defun skip-test-suite-children-p (result testsuite
)
1688 (let ((suite-name (class-name (class-of testsuite
))))
1689 (find-if (lambda (skip-datum)
1690 (and (eq suite-name
(car skip-datum
))
1691 (eq :including-children
(cdr skip-datum
))))
1692 (tests-to-skip result
))))
1694 (defmethod testsuite-run ((testsuite test-mixin
) (result test-result
))
1695 (unless (start-time result
)
1696 (setf (start-time result
) (get-internal-real-time)
1697 (start-time-universal result
) (get-universal-time)))
1699 (let* ((methods (testsuite-methods testsuite
))
1700 (suite-name (class-name (class-of testsuite
)))
1701 (*current-testsuite-name
* suite-name
))
1702 (loop for method in methods do
1703 (if (skip-test-case-p result suite-name method
)
1704 (skip-test-case result suite-name method
)
1705 (run-test-internal testsuite method result
)))
1706 (when (and *test-do-children?
*
1707 (not (skip-test-suite-children-p result testsuite
)))
1708 (loop for subclass in
(direct-subclasses (class-of testsuite
))
1709 when
(and (testsuite-p subclass
)
1710 (not (member (class-name subclass
)
1711 (suites-run result
)))) do
1712 (run-tests-internal (class-name subclass
)
1714 (setf (end-time result
) (get-universal-time))))
1716 (defmethod more-prototypes-p ((testsuite test-mixin
))
1717 (not (null (prototypes testsuite
))))
1719 (defmethod initialize-prototypes ((testsuite test-mixin
))
1720 (setf (prototypes testsuite
)
1721 (list (make-single-prototype testsuite
))))
1723 (defmethod make-single-prototype ((testsuite test-mixin
))
1726 (defmethod initialize-prototypes :around
((suite test-mixin
))
1727 (unless (prototypes-initialized? suite
)
1728 (setf (slot-value suite
'prototypes-initialized?
) t
)
1729 (call-next-method)))
1731 (defmethod next-prototype ((testsuite test-mixin
))
1732 (setf (current-values testsuite
) (first (prototypes testsuite
))
1733 (prototypes testsuite
) (rest (prototypes testsuite
)))
1734 (dolist (key.value
(current-values testsuite
))
1735 (setf (test-environment-value (car key.value
)) (cdr key.value
))))
1737 (defmethod run-test-internal ((suite test-mixin
) (name symbol
) result
)
1738 (when (and *test-print-test-case-names
*
1739 (eq (test-mode result
) :multiple
))
1740 (print-lift-message "~& run: ~a" name
))
1741 (let ((*current-test-case-name
* name
))
1745 (handler-bind ((warning #'muffle-warning
)
1746 ; ignore warnings...
1749 (report-test-problem
1750 'test-error result suite
1751 *current-test-case-name
* condition
1752 :backtrace
(get-backtrace condition
))
1753 (if (and *test-break-on-errors?
*
1754 (not (testcase-expects-error-p)))
1755 (invoke-debugger condition
)
1757 (setf (current-method suite
) name
)
1758 (start-test result suite name
)
1762 (setf (current-step suite
) :testing
)
1764 (getf (test-data suite
) :seconds
)
1765 (getf (test-data suite
) :conses
)
1766 (lift-test suite name
))
1767 (check-for-surprises suite
))
1769 (teardown-test suite
)
1770 (end-test result suite name
)))
1771 (ensure-failed (condition)
1772 (report-test-problem
1773 'test-failure result suite
1774 *current-test-case-name
* condition
)
1775 (if (and *test-break-on-failures?
*
1776 (not (testcase-expects-failure-p)))
1777 (invoke-debugger condition
)
1779 (retry-test () :report
"Retry the test."
1782 (push (list (type-of suite
) *current-test-case-name
* (test-data suite
))
1784 (when *lift-report-pathname
*
1785 (let ((current (first (tests-run result
))))
1786 (summarize-single-test
1787 :save
(first current
) (second current
) (third current
)
1788 :stream
*lift-report-pathname
*))))
1789 (setf *current-test-case-name
* name
1790 *test-result
* result
))
1792 (defun testcase-expects-error-p (&optional
(test *current-test
*))
1793 (let* ((options (getf (test-data test
) :options
)))
1794 (or (testsuite-expects-error test
)
1795 (second (member :expected-error options
)))))
1797 (defun testcase-expects-failure-p (&optional
(test *current-test
*))
1798 (let* ((options (getf (test-data test
) :options
)))
1799 (or (testsuite-expects-failure test
)
1800 (second (member :expected-failure options
)))))
1802 (defun testcase-expects-problem-p (&optional
(test *current-test
*))
1803 (let* ((options (getf (test-data test
) :options
)))
1804 (second (member :expected-problem options
))))
1806 (defun check-for-surprises (testsuite)
1807 (let* ((expected-failure-p (testcase-expects-failure-p testsuite
))
1808 (expected-error-p (testcase-expects-error-p testsuite
))
1809 (expected-problem-p (testcase-expects-problem-p testsuite
))
1813 (setf (slot-value testsuite
'expected-failure-p
) expected-failure-p
))
1815 (setf (slot-value testsuite
'expected-error-p
) expected-error-p
))
1817 (setf (slot-value testsuite
'expected-problem-p
) expected-problem-p
)))
1819 ((expected-failure-p testsuite
)
1821 (make-condition 'unexpected-success-failure
1823 :expected-more
(expected-failure-p testsuite
))))
1824 ((expected-error-p testsuite
)
1826 (make-condition 'unexpected-success-failure
1828 :expected-more
(expected-error-p testsuite
))))
1829 ((expected-problem-p testsuite
)
1831 (make-condition 'unexpected-success-failure
1833 :expected-more
(expected-problem-p testsuite
)))))
1835 (if (find-restart 'ensure-failed
)
1836 (invoke-restart 'ensure-failed condition
)
1837 (warn condition
)))))
1839 (defun report-test-problem (problem-type result suite method condition
1844 (declare (ignore docs option
))
1845 (cond ((and (eq problem-type
'test-failure
)
1846 (not (typep condition
'unexpected-success-failure
))
1847 (testcase-expects-failure-p suite
))
1848 (setf problem-type
'test-expected-failure
1849 option
:expected-failure
))
1850 ((and (eq problem-type
'test-error
)
1851 (testcase-expects-error-p suite
))
1852 (setf problem-type
'test-expected-error
1853 option
:expected-error
))
1854 ((and (or (eq problem-type
'test-failure
)
1855 (eq problem-type
'test-error
))
1856 (testcase-expects-problem-p suite
))
1857 (setf problem-type
(or (and (eq problem-type
'test-failure
)
1858 'test-expected-failure
)
1859 (and (eq problem-type
'test-error
)
1860 'test-expected-error
))
1861 option
:expected-problem
)))
1862 (let ((problem (apply #'make-instance problem-type
1865 :test-condition condition
1866 :test-step
(current-step suite
) args
)))
1867 (setf (getf (test-data suite
) :problem
) problem
)
1869 ((or test-failure testsuite-failure
) (push problem
(failures result
)))
1870 (test-expected-failure (push problem
(expected-failures result
)))
1871 ((or test-error testsuite-error
) (push problem
(errors result
)))
1872 (test-expected-error (push problem
(expected-errors result
))))
1875 ;;; ---------------------------------------------------------------------------
1876 ;;; test-result and printing
1877 ;;; ---------------------------------------------------------------------------
1879 (defun get-test-print-length ()
1880 (let ((foo *test-print-length
*))
1881 (if (eq foo
:follow-print
) *print-length
* foo
)))
1883 (defun get-test-print-level ()
1884 (let ((foo *test-print-level
*))
1885 (if (eq foo
:follow-print
) *print-level
* foo
)))
1887 (defmethod start-test ((result test-result
) (suite test-mixin
) name
)
1888 (declare (ignore name
))
1889 (setf (current-step suite
) :start-test
1891 `(:start-time
,(get-internal-real-time)
1892 :start-time-universal
,(get-universal-time))))
1894 (defmethod end-test ((result test-result
) (suite test-mixin
) name
)
1895 (declare (ignore name
))
1896 (setf (current-step suite
) :end-test
1897 (getf (test-data suite
) :end-time
) (get-internal-real-time)
1898 (end-time result
) (get-internal-real-time)
1899 (getf (test-data suite
) :end-time-universal
) (get-universal-time)
1900 (end-time-universal result
) (get-universal-time)))
1902 (defun make-test-result (for test-mode
&rest args
)
1903 (apply #'make-instance
'test-result
1905 :test-mode test-mode
1908 (defun testing-interactively-p ()
1911 (defmethod print-object ((tr test-result
) stream
)
1912 (let ((complete-success?
(and (null (errors tr
))
1913 (null (failures tr
))
1914 (null (expected-failures tr
))
1915 (null (expected-errors tr
)))))
1916 (let* ((*print-level
* (get-test-print-level))
1917 (*print-length
* (get-test-print-length))
1918 (non-failure-failures
1921 (member (class-of (test-condition failure
))
1922 (subclasses 'unexpected-success-failure
:proper? nil
)))
1923 (expected-failures tr
)))
1924 (expected-failures (- (length (expected-failures tr
))
1925 non-failure-failures
)))
1926 (print-unreadable-object (tr stream
)
1927 (cond ((and (null (tests-run tr
)) complete-success?
)
1928 (format stream
"~A: no tests defined" (results-for tr
)))
1929 ((eq (test-mode tr
) :single
)
1930 (cond ((test-interactive? tr
)
1932 (cond (complete-success?
1933 (format stream
"Test passed"))
1935 (format stream
"Error during testing"))
1936 ((expected-errors tr
)
1937 (format stream
"Expected error during testing"))
1939 (format stream
"Test failed"))
1940 ((plusp non-failure-failures
)
1941 (format stream
"Test succeeded unexpectedly"))
1943 (format stream
"Test failed expectedly"))))
1946 (format stream
"~A.~A ~A"
1948 (first (first (tests-run tr
)))
1949 (cond (complete-success?
1955 (when (or (expected-errors tr
) (expected-failures tr
))
1956 (format stream
"(~[~:;, ~:*~A expected failure~:P~]~[~:;, ~:*~A succeeded unexpectedly~]~[~:;, ~:*~A expected error~:P~])"
1957 expected-failures non-failure-failures
1958 (expected-errors tr
))))))
1960 ;; multiple tests run
1961 (format stream
"Results for ~A " (results-for tr
))
1962 (if complete-success?
1963 (format stream
"[~A Successful test~:P]"
1964 (length (tests-run tr
)))
1965 (format stream
"~A Test~:P~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Error~:P~]~[~:;, ~:*~A Expected failure~:P~]~[~:;, ~:*~A Expected error~:P~]"
1966 (length (tests-run tr
))
1967 (length (failures tr
))
1968 (length (errors tr
))
1969 (length (expected-failures tr
))
1970 (length (expected-errors tr
))))))
1971 ;; note that suites with no tests think that they are completely
1972 ;; successful. Optimistic little buggers, huh?
1973 (when (and (not complete-success?
) *test-describe-if-not-successful?
*)
1974 (format stream
"~%")
1975 (print-test-result-details stream tr t t
))))))
1977 (defmethod describe-object ((result test-result
) stream
)
1978 (describe-test-result result stream
))
1980 (defmethod describe-test-result (result stream
1982 (show-details-p *test-show-details-p
*)
1983 (show-expected-p *test-show-expected-p
*)
1984 (show-code-p *test-show-code-p
*))
1985 (let* ((number-of-failures (length (failures result
)))
1986 (number-of-errors (length (errors result
)))
1987 (number-of-expected-errors (length (expected-errors result
)))
1988 (non-failure-failures
1991 (member (class-of (test-condition failure
))
1992 (subclasses 'unexpected-success-failure
:proper? nil
)))
1993 (expected-failures result
)))
1994 (number-of-expected-failures (- (length (expected-failures result
))
1995 non-failure-failures
))
1996 (*print-level
* (get-test-print-level))
1997 (*print-length
* (get-test-print-length)))
1998 (unless *test-is-being-defined?
*
1999 (print-test-summary result stream
)
2000 (when (and show-details-p
2001 (or number-of-failures
2002 number-of-expected-failures
2004 number-of-expected-errors
))
2005 (format stream
"~%~%")
2006 (print-test-result-details
2007 stream result show-expected-p show-code-p
)
2008 (print-test-summary result stream
)))))
2010 (defun print-test-summary (result stream
)
2011 (let* ((number-of-failures (length (failures result
)))
2012 (number-of-errors (length (errors result
)))
2013 (number-of-expected-errors (length (expected-errors result
)))
2014 (non-failure-failures
2017 (member (class-of (test-condition failure
))
2018 (subclasses 'unexpected-success-failure
:proper? nil
)))
2019 (expected-failures result
)))
2020 (number-of-expected-failures (- (length (expected-failures result
))
2021 non-failure-failures
)))
2022 (format stream
"~&Test Report for ~A: ~D test~:P run"
2023 (results-for result
) (length (tests-run result
)))
2024 (cond ((or (failures result
) (errors result
)
2025 (expected-failures result
) (expected-errors result
))
2026 (format stream
"~[~:;, ~:*~A Error~:P~]~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Expected error~:P~]~[~:;, ~:*~A Expected failure~:P~]~[~:;, ~:*~A Successful Surprise~:P~]."
2029 number-of-expected-errors
2030 number-of-expected-failures
2031 non-failure-failures
))
2032 ((or (expected-failures result
) (expected-errors result
))
2033 (format stream
", all passed *~[~:;, ~:*~A Expected error~:P~]~[~:;, ~:*~A Expected failure~:P~])."
2034 number-of-expected-errors
2035 number-of-expected-failures
))
2037 (format stream
", all passed!")))))
2039 (defun print-test-result-details (stream result show-expected-p show-code-p
)
2040 (loop for report in
(errors result
) do
2041 (print-test-problem "ERROR : " report stream
2043 (loop for report in
(failures result
) do
2044 (print-test-problem "Failure: " report stream
2046 (when show-expected-p
2047 (loop for report in
(expected-failures result
) do
2048 (print-test-problem "Expected failure: " report stream
2050 (loop for report in
(expected-errors result
) do
2051 (print-test-problem "Expected Error : " report stream
2054 (defun print-test-problem (prefix report stream show-code-p
)
2055 (let* ((suite (testsuite report
))
2056 (method (test-method report
))
2057 (condition (test-condition report
))
2058 (code (test-report-code suite method
))
2059 (testsuite-name method
))
2060 (format stream
"~&~A~(~A : ~A~)" prefix
(type-of suite
) testsuite-name
)
2061 (let ((doc-string (gethash testsuite-name
2062 (test-case-documentation
2063 (class-name (class-of suite
))))))
2065 (format stream
"~&~A" doc-string
)))
2067 (setf code
(with-output-to-string (out)
2068 (pprint code out
))))
2069 (format stream
"~&~< ~@;~
2070 ~@[Condition: ~<~@;~A~:>~]~
2072 ~&~:>" (list (list condition
) code
))))
2075 ;;; ---------------------------------------------------------------------------
2077 ;;; ---------------------------------------------------------------------------
2079 (defclass test-problem-mixin
()
2080 ((testsuite :initform nil
:initarg
:testsuite
:reader testsuite
)
2081 (test-method :initform nil
:initarg
:test-method
:reader test-method
)
2082 (test-condition :initform nil
2083 :initarg
:test-condition
2084 :reader test-condition
)
2085 (test-problem-kind :reader test-problem-kind
:allocation
:class
)
2086 (test-step :initform nil
:initarg
:test-step
:reader test-step
)))
2088 (defmethod print-object ((problem test-problem-mixin
) stream
)
2089 (print-unreadable-object (problem stream
)
2090 (format stream
"TEST-~@:(~A~): ~A in ~A"
2091 (test-problem-kind problem
)
2092 (name (testsuite problem
))
2093 (test-method problem
))))
2095 (defclass generic-problem
(test-problem-mixin)
2096 ((test-problem-kind :initarg
:test-problem-kind
2097 :allocation
:class
)))
2099 (defclass expected-problem-mixin
()
2100 ((documentation :initform nil
2101 :initarg
:documentation
2102 :accessor failure-documentation
)))
2104 (defclass test-expected-failure
(expected-problem-mixin generic-problem
)
2107 :test-problem-kind
"Expected failure"))
2109 (defclass test-failure
(generic-problem)
2112 :test-problem-kind
"failure"))
2114 (defclass test-error-mixin
(generic-problem)
2115 ((backtrace :initform nil
:initarg
:backtrace
:reader backtrace
)))
2117 (defclass test-expected-error
(expected-problem-mixin test-error-mixin
)
2120 :test-problem-kind
"Expected error"))
2122 (defclass test-error
(test-error-mixin)
2125 :test-problem-kind
"Error"))
2127 (defclass testsuite-error
(test-error-mixin)
2130 :test-problem-kind
"Testsuite error"))
2132 (defclass testsuite-failure
(generic-problem)
2135 :test-problem-kind
"Testsuite failure"))
2137 (defmethod test-report-code ((testsuite test-mixin
) (method symbol
))
2138 (let* ((class-name (class-name (class-of testsuite
))))
2140 (test-name->code-table class-name
))))
2142 ;;; ---------------------------------------------------------------------------
2144 ;;; ---------------------------------------------------------------------------
2146 (defun remove-test-methods (test-name)
2148 (length (testsuite-tests test-name
))
2149 (setf (testsuite-tests test-name
) nil
)))
2151 (defun remove-previous-definitions (classname)
2152 "Remove the methods of this class and all its subclasses."
2153 (let ((classes-removed nil
)
2154 (class (find-class classname nil
))
2157 (loop for subclass in
(subclasses class
:proper? nil
) do
2158 (push subclass classes-removed
)
2160 (remove-test-methods (class-name subclass
)))
2162 ;;?? causing more trouble than it solves...??
2163 (setf (find-class (class-name subclass
)) nil
))
2165 (unless (length-1-list-p classes-removed
)
2167 "~&;;; Removed Test suite ~(~A~) and its subclasses (~{~<~s~>~^, ~})."
2170 (mapcar #'class-name classes-removed
))
2172 (unless (zerop removed-count
)
2174 "~&;;; Removed ~D methods from test suite ~(~A~)~@[ and its subclasses~]."
2175 removed-count classname
2176 (not (length-1-list-p classes-removed
)))))))
2178 (defun build-initialize-test-method ()
2179 (let ((initforms nil
)
2181 (slot-specs (def :slot-specs
)))
2182 (loop for slot in slot-specs do
2183 (when (and (member :initform
(rest slot
))
2184 (not (eq :unbound
(getf (rest slot
) :initform
))))
2185 (push (getf (rest slot
) :initform
) initforms
)
2186 (push (first slot
) slot-names
)))
2187 (setf slot-names
(nreverse slot-names
)
2188 initforms
(nreverse initforms
))
2190 `((defmethod make-single-prototype ((testsuite ,(def :testsuite-name
)))
2191 (let ((initargs (suite-initargs testsuite
)))
2194 (when (next-method-p) (call-next-method))
2196 (lambda (slot-name initform
)
2199 ,(intern (symbol-name slot-name
)
2202 slot-names initforms
))
2203 (list ,@(mapcar (lambda (slot-name)
2204 `(cons ',slot-name
,slot-name
))
2205 slot-names
)))))))))))
2207 (defun (setf test-environment-value
) (value name
)
2208 (pushnew (cons name value
) *test-environment
* :test
#'equal
)
2211 (defun test-environment-value (name)
2212 (cdr (assoc name
*test-environment
*)))
2214 (defun remove-from-test-environment (name)
2215 (setf *test-environment
*
2216 (remove name
*test-environment
* :key
#'car
)))
2218 (defun build-test-local-functions ()
2221 (lambda (function-spec)
2222 (destructuring-bind (name arglist
&body body
) (first function-spec
)
2223 `(defmethod flet-test-function ((testsuite ,(def :testsuite-name
))
2224 (function-name (eql ',name
))
2228 `(destructuring-bind ,arglist args
2230 `(progn ,@body
))))))
2233 (defun build-test-equality-test ()
2234 (let ((test-name (def :testsuite-name
))
2235 (equality-test (def :equality-test
)))
2237 (defmethod equality-test ((testsuite ,test-name
))
2240 (defun build-testsuite-expected-error ()
2241 (let ((test-name (def :testsuite-name
))
2242 (expected-error (def :expected-error
)))
2244 (defmethod testsuite-expects-error ((testsuite ,test-name
))
2246 ,expected-error
)))))
2248 (defun build-testsuite-expected-failure ()
2249 (let ((test-name (def :testsuite-name
))
2250 (expected-failure (def :expected-failure
)))
2252 (defmethod testsuite-expects-failure ((testsuite ,test-name
))
2254 ,expected-failure
)))))
2256 (defun build-test-teardown-method ()
2257 (let ((test-name (def :testsuite-name
))
2258 (slot-names (def :direct-slot-names
))
2259 (teardown (def :teardown
)))
2261 (unless (consp teardown
)
2262 (setf teardown
(list teardown
)))
2263 (when (length-1-list-p teardown
)
2264 (setf teardown
(list teardown
)))
2265 (when (symbolp (first teardown
))
2266 (setf teardown
(list teardown
))))
2267 (let* ((teardown-code `(,@(when teardown
2268 `((with-test-slots ,@teardown
)))))
2269 (test-code `(,@teardown-code
2270 ,@(mapcar (lambda (slot)
2271 `(remove-from-test-environment ',slot
))
2274 ,@(when teardown-code
2275 `((defmethod teardown-test progn
((testsuite ,test-name
))
2276 (when (run-teardown-p testsuite
:test-case
)
2278 ,@(when teardown-code
2279 `((defmethod testsuite-teardown ((testsuite ,test-name
)
2280 (result test-result
))
2281 (when (run-teardown-p testsuite
:testsuite
)
2284 (defun build-setup-test-method ()
2285 (let ((test-name (def :testsuite-name
))
2286 (setup (def :setup
)))
2288 (unless (consp setup
)
2289 (setf setup
(list setup
)))
2290 (when (length-1-list-p setup
)
2291 (setf setup
(list setup
)))
2292 (when (symbolp (first setup
))
2293 (setf setup
(list setup
)))
2294 (let ((code `((with-test-slots ,@setup
))))
2296 (defmethod setup-test :after
((testsuite ,test-name
))
2299 (defmethod setup-test :around
((test test-mixin
))
2300 (when (run-setup-p test
)
2302 (setf (slot-value test
'done-setup?
) t
)))
2304 (defun run-setup-p (testsuite)
2305 (case (run-setup testsuite
)
2306 (:once-per-session
(error "not implemented"))
2307 (:once-per-suite
(not (done-setup? testsuite
)))
2308 ((:once-per-test-case t
) t
)
2310 (t (error "Don't know about ~s for run-setup" (run-setup testsuite
)))))
2312 (defun run-teardown-p (testsuite when
)
2315 (ecase (run-setup testsuite
)
2316 (:once-per-session nil
)
2317 (:once-per-suite nil
)
2318 ((:once-per-test-case t
) t
)
2319 ((:never nil
) nil
)))
2321 (ecase (run-setup testsuite
)
2322 (:once-per-session nil
)
2324 ((:once-per-test-case t
) nil
)
2325 ((:never nil
) nil
)))))
2327 (defun build-test-test-method (test-class test-body options
)
2328 (multiple-value-bind (test-name body documentation name-supplied?
)
2329 (parse-test-body test-body
)
2330 (declare (ignorable name-supplied?
))
2331 (unless (consp (first body
))
2332 (setf body
(list body
)))
2334 (setf (gethash ',test-name
(test-name->code-table
',test-class
)) ',body
2335 (gethash ',body
(test-code->name-table
',test-class
)) ',test-name
)
2336 ,(when documentation
2337 `(setf (gethash ',test-name
(test-case-documentation ',test-class
))
2340 ,@(when name-supplied?
2341 `((ccl:record-source-file
',test-name
'test-case
)))
2342 (unless (find ',test-name
(testsuite-tests ',test-class
))
2343 (setf (testsuite-tests ',test-class
)
2344 (append (testsuite-tests ',test-class
) (list ',test-name
))))
2345 (defmethod lift-test ((testsuite ,test-class
) (case (eql ',test-name
)))
2347 `((setf (getf (test-data testsuite
) :options
)
2348 (list ,@(loop for
(k v
) on options by
#'cddr append
2350 (with-test-slots ,@body
))
2351 (setf *current-test-case-name
* ',test-name
)
2352 (when (and *test-print-when-defined?
*
2353 (not (or *test-is-being-compiled?
*
2355 (format *debug-io
* "~&;Test Created: ~(~S.~S~)."
2356 ',test-class
',test-name
))
2357 *current-test-case-name
*)))
2359 (defun build-dynamics ()
2361 (dolist (putative-pair (def :dynamic-variables
))
2362 (if (atom putative-pair
)
2363 (push (list putative-pair nil
) result
)
2364 (push putative-pair result
)))
2367 (defun parse-test-body (test-body)
2368 (let ((test-name nil
)
2372 (test-number (1+ (testsuite-test-count *current-testsuite-name
*)))
2373 (name-supplied? nil
))
2374 ;; parse out any documentation
2375 (loop for form in test-body do
2376 (if (and (consp form
)
2377 (keywordp (first form
))
2378 (eq :documentation
(first form
)))
2379 (setf documentation
(second form
))
2380 (push form parsed-body
)))
2381 (setf test-body
(nreverse parsed-body
))
2382 (setf test-name
(first test-body
))
2383 (cond ((symbolp test-name
)
2385 (intern (format nil
"~A" test-name
))
2386 body
(rest test-body
)
2388 ((and (test-code->name-table
*current-testsuite-name
*)
2391 (test-code->name-table
*current-testsuite-name
*))))
2392 (setf body test-body
))
2395 (intern (format nil
"TEST-~A"
2398 (values test-name body documentation name-supplied?
)))
2400 (defun build-test-class ()
2401 ;; for now, we don't generate code from :class-def code-blocks
2402 ;; they are executed only for effect.
2403 (loop for
(nil . block
) in
*code-blocks
*
2406 (eq (operate-when block
) :class-def
)
2407 (or (not (filter block
))
2408 (funcall (filter block
)))) collect
2409 (funcall (code block
)))
2410 (unless (some (lambda (superclass)
2411 (testsuite-p superclass
))
2412 (def :superclasses
))
2413 (pushnew 'test-mixin
(def :superclasses
)))
2414 ;; build basic class and standard class
2415 `(defclass ,(def :testsuite-name
) (,@(def :superclasses
))
2417 ,@(when (def :documentation
)
2418 `((:documentation
,(def :documentation
))))
2420 :test-slot-names
',(def :slot-names
)
2421 ,@(def :default-initargs
))))
2423 (defun parse-test-slots (slot-specs)
2424 (loop for spec in slot-specs collect
2425 (let ((parsed-spec spec
))
2426 (if (member :initform parsed-spec
)
2427 (let ((pos (position :initform parsed-spec
)))
2428 (append (subseq parsed-spec
0 pos
)
2429 (subseq parsed-spec
(+ pos
2))))
2432 (defmethod testsuite-p ((classname symbol
))
2433 (let ((class (find-class classname nil
)))
2436 (typep (allocate-instance class
) 'test-mixin
)
2438 (error (c) (declare (ignore c
)) (values nil
)))))
2440 (defmethod testsuite-p ((object standard-object
))
2441 (testsuite-p (class-name (class-of object
))))
2443 (defmethod testsuite-p ((class standard-class
))
2444 (testsuite-p (class-name class
)))
2446 (defmethod testsuite-methods ((classname symbol
))
2447 (testsuite-tests classname
))
2449 (defmethod testsuite-methods ((test test-mixin
))
2450 (testsuite-methods (class-name (class-of test
))))
2452 (defmethod testsuite-methods ((test standard-class
))
2453 (testsuite-methods (class-name test
)))
2456 ;; some handy properties
2457 (defclass-property test-slots
)
2458 (defclass-property test-code-
>name-table
)
2459 (defclass-property test-name-
>code-table
)
2460 (defclass-property test-case-documentation
)
2461 (defclass-property testsuite-prototype
)
2462 (defclass-property testsuite-tests
)
2463 (defclass-property testsuite-dynamic-variables
)
2465 ;;?? issue 27: break encapsulation of code blocks
2466 (defclass-property testsuite-function-specs
)
2468 (defun empty-test-tables (test-name)
2469 (when (find-class test-name nil
)
2470 (setf (test-code->name-table test-name
)
2471 (make-hash-table :test
#'equal
)
2472 (test-name->code-table test-name
)
2473 (make-hash-table :test
#'equal
)
2474 (test-case-documentation test-name
)
2475 (make-hash-table :test
#'equal
))))
2477 (pushnew :timeout
*deftest-clauses
*)
2480 :timeout
1 :class-def
2481 (lambda () (def :timeout
))
2482 '((setf (def :timeout
) (cleanup-parsed-parameter value
)))
2484 (unless (some (lambda (super)
2485 (member (find-class 'process-test-mixin
)
2486 (superclasses super
)))
2487 (def :superclasses
))
2488 (pushnew 'process-test-mixin
(def :superclasses
)))
2489 (push (def :timeout
) (def :default-initargs
))
2490 (push :maximum-time
(def :default-initargs
))
2493 (defclass process-test-mixin
(test-mixin)
2494 ((maximum-time :initform
*test-maximum-time
*
2495 :accessor maximum-time
2496 :initarg
:maximum-time
)))
2498 (defclass test-timeout-failure
(test-failure)
2499 ((test-problem-kind :initform
"Timeout" :allocation
:class
)))
2501 (defmethod lift-test :around
((suite test-mixin
) name
)
2503 (with-profile-report ((format nil
"~a-~a"
2504 (testsuite-name suite
) name
)
2507 (call-next-method)))
2509 (defmethod do-testing :around
((testsuite process-test-mixin
) result fn
)
2510 (declare (ignore fn
))
2512 (with-timeout ((maximum-time testsuite
))
2516 (declare (ignore c
))
2517 (report-test-problem
2518 'test-timeout-failure result testsuite
(current-method testsuite
)
2519 (make-instance 'test-timeout-condition
2520 :maximum-time
(maximum-time testsuite
))))))
2523 ;; some introspection
2525 (defun liftpropos (name &key
(include-cases? nil
))
2526 (declare (ignore include-cases?
))
2528 (real-name (etypecase name
2530 (symbol (symbol-name name
)))))
2532 (lambda (suite level
)
2533 (declare (ignore level
))
2534 (let ((suite-name (symbol-name (class-name suite
))))
2535 (when (search real-name suite-name
:test
#'char-equal
)
2536 (push suite-name result
))))
2538 (sort result
#'string-lessp
)))
2540 (defun map-testsuites (fn start-at
)
2541 (let ((visited (make-hash-table)))
2542 (labels ((do-it (suite level
)
2543 (unless (gethash suite visited
)
2544 (setf (gethash suite visited
) t
)
2545 (funcall fn suite level
)
2546 (loop for subclass in
(subclasses suite
:proper? t
) do
2547 (do-it subclass
(1+ level
))))))
2548 (do-it (find-class (find-testsuite start-at
) nil
) 0))))
2550 (defun testsuites (&optional
(start-at 'test-mixin
))
2551 "Returns a list of testsuite classes. The optional parameter provides
2552 control over where in the test hierarchy the search begins."
2554 (map-testsuites (lambda (suite level
)
2555 (declare (ignore level
))
2556 (push suite result
))
2560 (defun print-tests (&key
(include-cases? t
) (start-at 'test-mixin
) (stream t
))
2561 "Prints all of the defined test classes from :start-at on down."
2563 (lambda (suite level
)
2564 (let ((indent (coerce (make-list (* level
3) :initial-element
#\Space
)
2566 (name (class-name suite
)))
2567 (format stream
"~&~a~s (~:d)"
2570 (length (testsuite-methods name
)))
2571 (when include-cases?
2572 (loop for method-name in
(testsuite-tests name
) do
2573 (format stream
"~&~a ~a" indent method-name
)))))
2576 (defun list-tests (&key
(include-cases? t
) (start-at 'test-mixin
) (stream t
))
2577 "Lists all of the defined test classes from :start-at on down."
2578 (mapc (lambda (subclass)
2579 (let ((subclass-name (class-name subclass
)))
2580 (format stream
"~&~s (~:d)"
2582 (length (testsuite-methods subclass-name
)))
2583 (when include-cases?
2584 (loop for method-name in
(testsuite-tests subclass-name
) do
2585 (format stream
"~& ~a" method-name
)))))
2586 (testsuites start-at
))
2589 (defun testsuite-test-count (testsuite)
2590 (or (and *testsuite-test-count
*
2591 (prog1 *testsuite-test-count
* (incf *testsuite-test-count
*)))
2592 (length (testsuite-methods testsuite
))))
2594 (defmethod find-testsuite ((suite symbol
))
2595 (or (testsuite-p suite
)
2596 (find-testsuite (symbol-name suite
))))
2598 (defmethod find-testsuite ((suite-name string
))
2600 (possibilities (remove-duplicates
2601 (loop for p in
(list-all-packages)
2602 when
(and (setf temp
(find-symbol suite-name p
))
2603 (find-class temp nil
)
2604 (subtypep temp
'test-mixin
)) collect
2606 (cond ((null possibilities
)
2607 (error 'testsuite-not-defined
:testsuite-name suite-name
))
2608 ((= (length possibilities
) 1)
2609 (first possibilities
))
2611 (error "There are several test suites named ~s: they are ~{~s~^, ~}"
2612 suite-name possibilities
)))))
2614 (defun test-case-p (suite-class name
)
2615 (find-method #'lift-test nil
`(,suite-class
(eql ,name
)) nil
))
2619 (find-class (find-testsuite 'test-cluster-indexing-locally
) nil
)
2620 'db.agraph.tests
::index-them
)
2623 (find-test-case (find-class (find-testsuite 'test-cluster-indexing-locally
))
2626 (defmethod find-test-case ((suite symbol
) name
)
2627 (find-test-case (find-class (find-testsuite suite
)) name
))
2629 (defmethod find-test-case ((suite test-mixin
) name
)
2630 (find-test-case (class-of suite
) name
))
2632 (defmethod find-test-case ((suite-class standard-class
) (name symbol
))
2633 (or (and (test-case-p suite-class name
) name
)
2634 (find-test-case suite-class
(symbol-name name
))))
2636 (defmethod find-test-case ((suite test-mixin
) (name string
))
2637 (find-test-case (class-of suite
) name
))
2639 (defmethod find-test-case ((suite-class standard-class
) (name string
))
2641 (possibilities (remove-duplicates
2642 (loop for p in
(list-all-packages)
2643 when
(and (setf temp
(find-symbol name p
))
2644 (test-case-p suite-class temp
)) collect
2646 (cond ((null possibilities
)
2647 (error 'test-case-not-defined
2648 :testsuite-name suite-class
:test-case-name name
))
2649 ((= (length possibilities
) 1)
2650 (first possibilities
))
2652 (error "There are several test cases of ~s named ~s: they are ~{~s~^, ~}"
2653 suite-class name possibilities
)))))
2655 (defun last-test-status ()
2656 (cond ((typep *test-result
* 'test-result
)
2657 (cond ((and (null (errors *test-result
*))
2658 (null (failures *test-result
*)))
2660 ((and (errors *test-result
*)
2661 (failures *test-result
*))
2662 :errors-and-failures
)
2663 ((errors *test-result
*)
2665 ((failures *test-result
*)
2670 (defun suite-tested-p (suite &key
(result *test-result
*))
2672 (typep *test-result
* 'test-result
)
2673 (slot-exists-p result
'suites-run
)
2674 (slot-boundp result
'suites-run
)
2675 (consp (suites-run result
))
2676 (find suite
(suites-run result
))))
2678 ;; FIXME -- abstract and merge with unique-directory
2679 (defun unique-filename (pathname)
2680 (let ((date-part (date-stamp)))
2686 :name
(format nil
"~a-~a-~d"
2687 (pathname-name pathname
)
2690 (unless (probe-file name
)
2691 (return-from unique-filename name
)))
2692 (error "Unable to find unique pathname for ~a" pathname
)))
2694 ;; FIXME -- abstract and merge with unique-filename
2695 (defun unique-directory (pathname)
2696 (when (or (pathname-name pathname
) (pathname-type pathname
))
2697 (setf pathname
(make-pathname
2700 :directory
`(,@(pathname-directory pathname
)
2701 ,(format nil
"~a~@[.~a~]"
2702 (pathname-name pathname
)
2703 (pathname-type pathname
)))
2704 :defaults pathname
)))
2705 (or (and (not (probe-file pathname
)) pathname
)
2706 (let ((date-part (date-stamp)))
2714 :directory
`(:relative
2715 ,(format nil
"~@[~a-~]~a-~d"
2716 (and (stringp (pathname-name pathname
))
2717 (pathname-name pathname
))
2720 (unless (probe-file name
)
2722 (error "Unable to find unique pathname for ~a" pathname
)))
2724 (defun date-stamp (&key
(datetime (get-universal-time)) (include-time? nil
))
2725 (multiple-value-bind
2726 (second minute hour day month year day-of-the-week
)
2727 (decode-universal-time datetime
)
2728 (declare (ignore day-of-the-week
))
2729 (let ((date-part (format nil
"~d-~2,'0d-~2,'0d" year month day
))
2730 (time-part (and include-time?
2731 (list (format nil
"-~2,'0d-~2,'0d-~2,'0d"
2732 hour minute second
)))))
2733 (apply 'concatenate
'string date-part time-part
))))
2736 (date-stamp :include-time? t
)
2738 ;;?? might be "cleaner" with a macrolet (cf. lift-result)
2739 (defun lift-property (name)
2740 (when *current-test
*
2741 (getf (getf (test-data *current-test
*) :properties
) name
)))
2744 (setf (getf (getf (third (first (tests-run *test-result
*))) :properties
) :foo
)
2747 (defun (setf lift-property
) (value name
)
2748 (when *current-test
*
2749 (setf (getf (getf (test-data *current-test
*) :properties
) name
) value
)))
2753 (defmacro with-test
(&body forms
)
2754 "Execute forms in the context of the current test class."
2755 (let* ((testsuite-name *current-testsuite-name
*)
2756 (test-case (make-instance test-class
)))
2757 `(eval-when (:execute
)
2759 (setup-test ,test-case
)
2761 (with-test-slots ,@forms
))
2762 (teardown-test ,test-case
)))))
