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
*
72 ensure-random-cases-failure
73 random-instance-for-suite
88 ;;; ---------------------------------------------------------------------------
90 ;;; ---------------------------------------------------------------------------
92 (defgeneric get-class
(thing &key error?
)
93 (: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.")
94 (:method
((thing symbol
) &key error?
)
95 (find-class thing error?
))
96 (:method
((thing standard-object
) &key error?
)
97 (declare (ignore error?
))
99 (:method
((thing t
) &key error?
)
100 (declare (ignore error?
))
102 (:method
((thing class
) &key error?
)
103 (declare (ignore error?
))
106 (defun direct-subclasses (thing)
107 "Returns the immediate subclasses of thing. Thing can be a class, object or symbol naming a class."
108 (class-direct-subclasses (get-class thing
)))
110 (defun map-subclasses (class fn
&key proper?
)
111 "Applies fn to each subclass of class. If proper? is true, then
112 the class itself is not included in the mapping. Proper? defaults to nil."
113 (let ((mapped (make-hash-table :test
#'eq
)))
114 (labels ((mapped-p (class)
115 (gethash class mapped
))
117 (unless (mapped-p class
)
118 (setf (gethash class mapped
) t
)
119 (unless (and proper? root
)
121 (mapc (lambda (class)
123 (direct-subclasses class
)))))
124 (do-it (get-class class
) t
))))
126 (defun subclasses (class &key
(proper? t
))
127 "Returns all of the subclasses of the class including the class itself."
129 (map-subclasses class
(lambda (class)
134 (defun superclasses (thing &key
(proper? t
))
135 "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."
136 (let ((result (class-precedence-list (get-class thing
))))
137 (if proper?
(rest result
) result
)))
139 (defun direct-superclasses (thing)
140 "Returns the immediate superclasses of thing. Thing can be a class, object or symbol naming a class."
141 (class-direct-superclasses (get-class thing
)))
143 (declaim (inline length-1-list-p
))
144 (defun length-1-list-p (x)
145 "Is x a list of length 1?"
146 (and (consp x
) (null (cdr x
))))
148 (defmacro defclass-property
(property &optional
(default nil default-supplied?
))
149 "Create getter and setter methods for 'property' on symbol's property lists."
150 (let ((real-name (intern (format nil
"~:@(~A~)" property
) :keyword
)))
152 (defgeneric ,property
(symbol))
153 (defgeneric (setf ,property
) (value symbol
))
154 (defmethod ,property
((class-name symbol
))
155 (get class-name
,real-name
,@(when default-supplied?
(list default
))))
156 (defmethod (setf ,property
) (value (class-name symbol
))
157 (setf (get class-name
,real-name
) value
)))))
159 (defvar *automatic-slot-accessors?
* nil
)
160 (defvar *automatic-slot-initargs?
* nil
)
161 (defvar *clos-slot-options
*
162 '(:initform
:initarg
:reader
:writer
163 :accessor
:documentation
:type
166 (defun parse-brief-slot
168 (automatic-accessors?
*automatic-slot-accessors?
*)
169 (automatic-initargs?
*automatic-slot-initargs?
*)
171 (conc-separator "-"))
172 "Returns a verbose-style slot specification given a brief style, consisting of
173 a single symbol, the name of the slot, or a list of the slot name, optional
174 initform, optional symbol specifying whether there is an initarg, reader, or
175 accessor, and optional documentation string. The specification of initarg,
176 reader and accessor is done by the letters I, R and A, respectively; to specify
177 none of those, give a symbol containing none of those letters, such as the
178 symbol *. This function is used in the macro `defclass-brief,' but has been
179 broken out as a function in its own right for those writing variants on the
180 `defclass' macro. If a verbose-style slot specification is given, it is
183 If `automatic-accessors? is true, an accessor is defined, whether A is
184 specified or not _unless_ R is specified. If `automatic-initargs? is true,
185 an initarg is defined whether I is specified or not. If `conc-name' is
186 specified, the accessor name has that prepended, with conc-separator, and then
189 All other CLOS slot options are processed normally."
193 (symbol (setf slot
(list slot
)))
196 (let* ((name (pop slot
))
197 (new-slot (list name
))
200 (done-documentation? nil
)
202 (accessor-added? nil
)
203 (initargs-added? nil
))
204 (flet ((make-conc-name ()
206 (intern (format nil
"~@:(~A~A~A~)"
207 conc-name conc-separator name
))
210 (add-option (option argument
)
211 (push option new-slot
)
212 (push argument new-slot
))
214 ;; Remove duplicate options before returning the slot spec.
215 (finish-new-slot (slot)
216 ;; XXX This code is overly loopy and opaque ---L
217 (destructuring-bind (slot-name &rest options
) slot
218 (let ((opts (make-hash-table)))
219 (loop for
(key val . d
) = options then d
221 doing
(pushnew val
(gethash key opts nil
) :test
#'equal
))
222 (loop for key being each hash-key of opts using
(hash-value vals
)
223 nconc
(mapcan #'(lambda (x) (list key x
)) vals
) into spec
224 finally
(return (cons slot-name spec
)))))))
226 (do* ((items slot
(rest items
))
227 (item (first items
) (first items
))
229 (clos-item?
(member item
*clos-slot-options
*)
230 (member item
*clos-slot-options
*)))
233 (unless done-initform?
234 (setf done-initform? t
)
236 (setf process-item? nil
)
237 (unless (eq item
:UNBOUND
)
238 (push :initform new-slot
)
239 (push item new-slot
))))
242 (unless (or done-spec?
(not (symbolp item
)) clos-item?
)
244 (setf process-item? nil
)
245 ;; If you've got an A, who cares about R
246 (when (find #\A
(string item
))
247 (setf accessor-added? t
)
248 (add-option :accessor
(make-conc-name)))
249 (when (and (not accessor-added?
) (find #\R
(string item
)))
250 (setf reader-added? t
)
251 (add-option :reader
(make-conc-name)))
252 (when (find #\I
(string item
))
253 (setf initargs-added? t
)
254 (add-option :initarg
(intern (string name
)
255 (find-package :keyword
))))))
258 (unless (or done-documentation?
(not (stringp item
)))
259 (setf done-documentation? t
)
260 (push :documentation new-slot
)
268 (push (first items
) new-slot
))))
270 (when (and automatic-initargs?
(not initargs-added?
))
271 (add-option :initarg
(intern (string name
) (find-package :keyword
))))
273 (when (and automatic-accessors?
274 (and (not accessor-added?
) (not reader-added?
)))
275 (add-option :accessor
(make-conc-name)))
277 ;; finish-new-slot cleans up duplicates
278 (finish-new-slot (nreverse new-slot
)))))
280 (defun convert-clauses-into-lists (clauses-and-options clauses-to-convert
)
281 ;; This is useful (for me at least!) for writing macros
282 (let ((parsed-clauses nil
))
283 (do* ((clauses clauses-and-options
(rest clauses
))
284 (clause (first clauses
) (first clauses
)))
286 (if (and (keywordp clause
)
287 (or (null clauses-to-convert
) (member clause clauses-to-convert
))
288 (not (length-1-list-p clauses
)))
290 (setf clauses
(rest clauses
))
291 (push (list clause
(first clauses
)) parsed-clauses
))
292 (push clause parsed-clauses
)))
293 (nreverse parsed-clauses
)))
295 (defun remove-leading-quote (list)
296 "Removes the first quote from a list if one is there."
297 (if (and (consp list
) (eql (first list
) 'quote
))
301 (defun cleanup-parsed-parameter (parameter)
302 (if (length-1-list-p parameter
)
306 ;;; ---------------------------------------------------------------------------
307 ;;; global environment thingies
308 ;;; ---------------------------------------------------------------------------
310 (defparameter *make-testsuite-arguments
*
311 '(:run-setup
:test-slot-names
:equality-test
:log-file
:timeout
312 :default-initargs
:profile
))
314 (defvar *current-testsuite-name
* nil
)
315 (defvar *current-test-case-name
* nil
)
317 (defvar *test-is-being-defined?
* nil
)
318 (defvar *test-is-being-compiled?
* nil
)
319 (defvar *test-is-being-loaded?
* nil
)
320 (defvar *test-is-being-executed?
* nil
)
322 (defvar *testsuite-test-count
* nil
323 "Temporary variable used to 'communicate' between deftestsuite and addtest.")
324 (defvar *lift-debug-output
* *debug-io
*
325 "Messages from LIFT will be sent to this stream. It can set to nil or
326 to an output stream. It defaults to *debug-io*.")
328 (defvar *test-maximum-time
* 2
329 "Maximum number of seconds a process test is allowed to run before we give up.")
331 (defvar *test-break-on-errors?
* nil
)
332 (defvar *test-break-on-failures?
* nil
)
333 (defvar *test-do-children?
* t
)
334 (defparameter *test-ignore-warnings?
* nil
335 "If true, LIFT will not cause a test to fail if a warning occurs while
336 the test is running. Note that this may interact oddly with ensure-warning.")
337 (defparameter *test-print-when-defined?
* nil
)
338 (defparameter *test-evaluate-when-defined?
* t
)
339 (defparameter *test-scratchpad
* nil
340 "A place to put things. This is set to nil before every test.")
341 (defparameter *test-notepad
* nil
342 "Another place to put things \(see {ref *test-scratchpad*}\).")
344 (defparameter *lift-equality-test
* 'equal
345 "The function used in ensure-same to test if two things are equal. If metatilities is loaded, then you might want to use samep.")
347 (defvar *test-describe-if-not-successful?
* nil
348 ;; Was t, but this behavior was extremely annoying since each
349 ;; time a test-restul appears in a stack backtrace it is printed
350 ;; over many unstructured lines.
351 "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.")
353 (defvar *test-print-length
* :follow-print
354 "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*`.")
355 (defvar *test-print-level
* :follow-print
356 "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.")
358 (defvar *test-print-testsuite-names
* t
359 "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*.")
361 (defvar *test-print-test-case-names
* nil
362 "If true, LIFT will print the name of each test-case before it runs. See also: *test-print-testsuite-names*.")
364 (defparameter *lift-tests-to-skip
* nil
365 "A lift of test-suites and (testsuite test-case) pairs that LIFT will ignore
366 during calls to run-tests.")
368 (defvar *test-result
* nil
369 "Set to the most recent test result by calls to run-test or run-tests.")
371 (defvar *test-environment
* nil
)
373 (defvar *test-metadata
* (list)
374 "A place for LIFT to put stuff.")
376 (defvar *current-test
* nil
377 "The current testsuite.")
379 (defvar *lift-dribble-pathname
* nil
380 "If bound, then test output from run-tests will be sent to this file in
381 in addition to *lift-standard-output*. It can be set to nil or to a pathname.")
383 (defvar *lift-report-pathname
* nil
384 "If bound to a pathname or stream, then a summary of test information will
385 be written to it for later processing. It can be set to:
387 * `nil` - generate no output
388 * pathname designator - send output to this pathname
389 * `t` - send output to a pathname constructed from the name of the system
390 being tested (this only works if ASDF is being used to test the system).
392 As an example of the last case, if LIFT is testing a system named ...
395 (defvar *lift-standard-output
* *standard-output
*
396 "Output from tests will be sent to this stream. If can set to nil or
397 to an output stream. It defaults to *standard-output*.")
399 (defvar *lift-if-dribble-exists
* :append
400 "Specifies what to do to any existing file at *lift-dribble-pathname*. It
401 can be :supersede, :append, or :error.")
403 (defvar *test-show-expected-p
* t
)
405 (defvar *test-show-details-p
* t
)
407 (defvar *test-show-code-p
* t
)
409 ;;; ---------------------------------------------------------------------------
410 ;;; Error messages and warnings
411 ;;; ---------------------------------------------------------------------------
413 (defparameter +lift-test-name-not-supplied-with-test-class
+
414 "if you specify a test-class, you must also specify a test-name.")
416 (defparameter +lift-test-class-not-found
+
417 "test class '~S' not found.")
419 (defparameter +lift-confused-about-arguments
+
420 "I'm confused about what you said?!")
422 (defparameter +lift-no-current-test-class
+
423 "There is no current-test-class to use as a default.")
425 (defparameter +lift-could-not-find-test
+
426 "Could not find test: ~S.~S")
428 (defparameter +run-tests-null-test-case
+
429 "There is no current testsuite (possibly because
430 none have been defined yet?). You can specify the
431 testsuite to test by evaluating (run-tests :suite <suitename>).")
433 (defparameter +lift-unable-to-parse-test-name-and-class
+
437 ;;; ---------------------------------------------------------------------------
439 ;;; ---------------------------------------------------------------------------
441 (define-condition lift-compile-error
(error)
444 :initarg
:lift-message
))
445 (:report
(lambda (c s
)
446 (format s
"Compile error: '~S'" (msg c
)))))
448 (define-condition testsuite-not-defined
(lift-compile-error)
449 ((testsuite-name :reader testsuite-name
450 :initarg
:testsuite-name
))
451 (:report
(lambda (c s
)
452 (format s
"Test class ~A not defined before it was used."
453 (testsuite-name c
)))))
455 (define-condition test-case-not-defined
(lift-compile-error)
456 ((testsuite-name :reader testsuite-name
457 :initarg
:testsuite-name
)
458 (test-case-name :reader test-case-name
459 :initarg
:test-case-name
))
460 (:report
(lambda (c s
)
461 (format s
"Testsuite ~s has no test-case named ~s."
463 (test-case-name c
)))))
465 (define-condition test-condition
(warning)
466 ((message :initform
""
469 (:report
(lambda (c s
)
471 (format s
"~%~A" (message c
))))))
473 (define-condition test-timeout-condition
(test-condition)
474 ((maximum-time :initform
*test-maximum-time
*
475 :accessor maximum-time
476 :initarg
:maximum-time
))
477 (:report
(lambda (c s
)
478 (format s
"Test ran out of time (longer than ~S-second~:P)"
481 (define-condition ensure-failed-error
(test-condition)
482 ((assertion :initform
""
484 :initarg
:assertion
))
485 (:report
(lambda (c s
)
486 (format s
"Ensure failed: ~S ~@[(~a)~]"
487 (assertion c
) (message c
)))))
489 (define-condition ensure-null-failed-error
(ensure-failed-error)
493 (assertion :initform
""
495 :initarg
:assertion
))
496 (:report
(lambda (c s
)
497 (format s
"Ensure null failed: ~s evaluates to ~s ~@[(~a)~]"
498 (assertion c
) (value c
) (message c
)))))
500 (define-condition ensure-expected-condition
(test-condition)
501 ((expected-condition-type
503 :accessor expected-condition-type
504 :initarg
:expected-condition-type
)
507 :accessor the-condition
508 :initarg
:the-condition
))
509 (:report
(lambda (c s
)
510 (format s
"Expected ~A but got ~S"
511 (expected-condition-type c
)
512 (the-condition c
)))))
514 (define-condition ensure-not-same
(test-condition)
515 ((first-value :accessor first-value
516 :initarg
:first-value
)
517 (second-value :accessor second-value
518 :initarg
:second-value
)
521 (:report
(lambda (c s
)
522 (format s
"Ensure-same: ~S is not ~S to ~S~@[ (~a)~]"
523 (first-value c
) (test c
) (second-value c
)
526 (define-condition ensure-cases-failure
(test-condition)
527 ((total :initarg
:total
:initform
0)
528 (problems :initarg
:problems
:initform nil
))
529 (:report
(lambda (condition stream
)
530 (format stream
"Ensure-cases: ~d out of ~d cases failed. Failing cases are: ~{~% ~{~s (~a)~}~^, ~}"
531 (length (slot-value condition
'problems
))
532 (slot-value condition
'total
)
533 (slot-value condition
'problems
)))))
535 (define-condition unexpected-success-failure
(test-condition)
536 ((expected :reader expected
:initarg
:expected
)
537 (expected-more :reader expected-more
:initarg
:expected-more
))
538 (:report
(lambda (c s
)
539 (format s
"Test succeeded but we expected ~s (~s)"
541 (expected-more c
)))))
543 (defun build-lift-error-message (context message
&rest arguments
)
546 (apply #'format nil message arguments
)))
548 (defun signal-lift-error (context message
&rest arguments
)
549 (let ((c (make-condition
551 :lift-message
(apply #'build-lift-error-message
552 context message arguments
))))
556 (defun report-lift-error (context message
&rest arguments
)
557 (format *debug-io
* "~&~A."
558 (apply #'build-lift-error-message context message arguments
))
561 (defun lift-report-condition (c)
562 (format *debug-io
* "~&~A." c
))
564 (defmacro ensure
(predicate &key report arguments
)
565 "If ensure's `predicate` evaluates to false, then it will generate a
566 test failure. You can use the `report` and `arguments` keyword parameters
567 to customize the report generated in test results. For example:
570 :report \"I hope ~a does not = ~a\"
573 will generate a message like
575 Warning: Ensure failed: (= 23 12) (I hope 12 does not = 23)
577 (let ((gpredicate (gensym)))
578 `(let ((,gpredicate
,predicate
))
581 (let ((condition (make-condition
583 :assertion
',predicate
586 (format nil
,report
,@arguments
))))))
587 (if (find-restart 'ensure-failed
)
588 (invoke-restart 'ensure-failed condition
)
589 (warn condition
)))))))
591 (defmacro ensure-null
(predicate &key report arguments
)
592 "If ensure-null's `predicate` evaluates to true, then it will generate a
593 test failure. You can use the `report` and `arguments` keyword parameters
594 to customize the report generated in test results. See [ensure][] for more
597 `(let ((,g
,predicate
))
600 (let ((condition (make-condition 'ensure-null-failed-error
602 :assertion
',predicate
604 `(:message
(format nil
,report
,@arguments
))))))
605 (if (find-restart 'ensure-failed
)
606 (invoke-restart 'ensure-failed condition
)
607 (warn condition
)))))))
609 (defmacro ensure-condition
(condition &body body
)
610 "This macro is used to make sure that body really does produce condition."
611 (setf condition
(remove-leading-quote condition
))
612 (destructuring-bind (condition &key report arguments
)
613 (if (consp condition
) condition
(list condition
))
620 (declare (ignore cond
)) (setf ,g t
))
623 (let ((c (make-condition
624 'ensure-expected-condition
625 :expected-condition-type
',condition
628 `(:message
(format nil
,report
,arguments
))))))
629 (if (find-restart 'ensure-failed
)
630 (invoke-restart 'ensure-failed c
)
633 (if (find-restart 'ensure-failed
)
637 'ensure-expected-condition
638 :expected-condition-type
',condition
641 `(:message
(format nil
,report
,arguments
)))))
642 (warn "Ensure-condition didn't get the condition it expected."))))))))
644 (defmacro ensure-warning
(&body body
)
645 "Ensure-warning evaluates its body. If the body does *not* signal a
646 warning, then ensure-warning will generate a test failure."
647 `(ensure-condition warning
,@body
))
649 (defmacro ensure-error
(&body body
)
650 "Ensure-error evaluates its body. If the body does *not* signal an
651 error, then ensure-error will generate a test failure."
652 `(ensure-condition error
,@body
))
654 (defmacro ensure-same
655 (form values
&key
(test nil test-specified-p
)
656 (report nil
) (arguments nil
))
657 "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"
658 (setf test
(remove-leading-quote test
))
659 (when (and (consp test
)
660 (eq (first test
) 'function
))
661 (setf test
(second test
)))
662 (let ((block (gensym)))
664 (loop for value in
(multiple-value-list ,form
)
665 for other-value in
(multiple-value-list ,values
) do
666 (unless (funcall ,(if test-specified-p
(list 'quote test
)
667 '*lift-equality-test
*)
669 (maybe-raise-not-same-condition
671 ,(if test-specified-p
(list 'quote test
) '*lift-equality-test
*)
673 (return-from ,block nil
)))
676 (defmacro ensure-different
677 (form values
&key
(test nil test-specified-p
)
678 (report nil
) (arguments nil
))
679 "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"
680 ;; FIXME -- share code with ensure-same
681 (setf test
(remove-leading-quote test
))
682 (when (and (consp test
)
683 (eq (first test
) 'function
))
684 (setf test
(second test
)))
686 (loop for value in
(multiple-value-list ,form
)
687 for other-value in
(multiple-value-list ,values
) do
688 ;; WHEN instead of UNLESS
689 (when (funcall ,(if test-specified-p
691 '*lift-equality-test
*)
693 (maybe-raise-not-same-condition
695 ,(if test-specified-p
697 '*lift-equality-test
*) ,report
,@arguments
)))
700 (defun maybe-raise-not-same-condition (value-1 value-2 test
701 report
&rest arguments
)
702 (let ((condition (make-condition 'ensure-not-same
704 :second-value value-2
706 :message
(when report
708 report arguments
)))))
709 (if (find-restart 'ensure-failed
)
710 (invoke-restart 'ensure-failed condition
)
713 (defmacro ensure-cases
((&rest vars
) (&rest cases
) &body body
)
714 (let ((case (gensym))
717 `(let ((,problems nil
) (,total
0))
718 (loop for
,case in
,cases do
720 (destructuring-bind ,vars
,case
723 (ensure-failed (cond)
724 (push (list ,case cond
) ,problems
)))))
726 (let ((condition (make-condition
727 'ensure-cases-failure
729 :problems
,problems
)))
730 (if (find-restart 'ensure-failed
)
731 (invoke-restart 'ensure-failed condition
)
732 (warn condition
)))))))
735 ;;; ---------------------------------------------------------------------------
737 ;;; ---------------------------------------------------------------------------
739 (defclass test-mixin
()
740 ((name :initform nil
:initarg
:name
:accessor name
:reader testsuite-name
)
741 (run-setup :reader run-setup
:initarg
:run-setup
)
742 (done-setup?
:initform nil
:reader done-setup?
)
743 (done-dynamics?
:initform nil
:reader done-dynamics?
)
744 (prototypes :initform
(list (list)) :accessor prototypes
)
745 (prototypes-initialized?
:initform nil
:reader prototypes-initialized?
)
746 (current-values :initform nil
:accessor current-values
)
747 (test-slot-names :initform nil
:initarg
:test-slot-names
748 :reader test-slot-names
)
749 (current-step :initform
:created
:accessor current-step
)
750 (current-method :initform nil
:accessor current-method
)
751 (save-equality-test :initform nil
:reader save-equality-test
)
752 (log-file :initform nil
:initarg
:log-file
:reader log-file
)
753 (test-data :initform nil
:accessor test-data
)
754 (expected-failure-p :initform nil
:initarg
:expected-failure-p
755 :reader expected-failure-p
)
756 (expected-error-p :initform nil
:initarg
:expected-error-p
757 :reader expected-error-p
)
758 (expected-problem-p :initform nil
:initarg
:expected-problem-p
759 :reader expected-problem-p
)
762 :accessor suite-initargs
)
766 (:documentation
"A test suite")
768 :run-setup
:once-per-test-case
))
770 (defmethod equality-test ((suite test-mixin
))
773 (defclass test-result
()
774 ((results-for :initform nil
775 :initarg
:results-for
776 :accessor results-for
)
777 (tests-run :initform nil
:accessor tests-run
)
778 (suites-run :initform nil
:accessor suites-run
)
779 (failures :initform nil
:accessor failures
)
780 (expected-failures :initform nil
:accessor expected-failures
)
781 (errors :initform nil
:accessor errors
)
782 (expected-errors :initform nil
:accessor expected-errors
)
783 (test-mode :initform
:single
:initarg
:test-mode
:accessor test-mode
)
784 (test-interactive?
:initform nil
785 :initarg
:test-interactive?
:accessor test-interactive?
)
786 (real-start-time :initarg
:real-start-time
:reader real-start-time
)
787 (start-time :accessor start-time
:initform nil
)
788 (end-time :accessor end-time
)
789 (real-end-time :accessor real-end-time
)
790 (real-start-time-universal
791 :initarg
:real-start-time-universal
:reader real-start-time-universal
)
792 (start-time-universal :accessor start-time-universal
:initform nil
)
793 (end-time-universal :accessor end-time-universal
)
794 (real-end-time-universal :accessor real-end-time-universal
)
795 (properties :initform nil
:accessor test-result-properties
)
796 (tests-to-skip :initform nil
797 :initarg
:tests-to-skip
798 :reader tests-to-skip
799 :writer %set-tests-to-skip
))
801 :test-interactive?
*test-is-being-defined?
*
802 :real-start-time
(get-internal-real-time)
803 :real-start-time-universal
(get-universal-time)
804 :tests-to-skip
*lift-tests-to-skip
*))
806 (defmethod initialize-instance :after
807 ((result test-result
) &key tests-to-skip
)
810 (mapcar (lambda (datum)
811 (cond ((or (atom datum
)
812 (= (length datum
) 1))
813 (cons (find-testsuite datum
) nil
))
814 ((= (length datum
) 2)
815 (cons (find-testsuite (first datum
))
816 (or (and (keywordp (second datum
)) (second datum
))
817 (find-test-case (find-testsuite (first datum
))
820 (warn "Unable to interpret skip datum ~a. Ignoring."
825 (defun test-result-property (result property
&optional default
)
826 (getf (test-result-properties result
) property default
))
828 (defun (setf test-result-property
) (value result property
)
829 (setf (getf (test-result-properties result
) property
) value
))
831 (defun print-lift-message (message &rest args
)
832 (apply #'format
*lift-debug-output
* message args
)
833 (force-output *lift-debug-output
*))
835 (defgeneric testsuite-setup
(testsuite result
)
836 (:documentation
"Setup at the testsuite-level")
837 (:method
((testsuite test-mixin
) (result test-result
))
839 (:method
:before
((testsuite test-mixin
) (result test-result
))
840 (when (and *test-print-testsuite-names
*
841 (eq (test-mode result
) :multiple
))
842 (print-lift-message "~&Start: ~a" (type-of testsuite
)))
843 (push (type-of testsuite
) (suites-run result
))
844 (setf (current-step testsuite
) :testsuite-setup
)))
846 (defgeneric testsuite-run
(testsuite result
)
847 (:documentation
"Run the cases in this suite and it's children."))
849 (defgeneric testsuite-teardown
(testsuite result
)
850 (:documentation
"Cleanup at the testsuite level.")
851 (:method
((testsuite test-mixin
) (result test-result
))
854 (:method
:after
((testsuite test-mixin
) (result test-result
))
855 (setf (current-step testsuite
) :testsuite-teardown
856 (real-end-time result
) (get-internal-real-time)
857 (real-end-time-universal result
) (get-universal-time))))
859 (defgeneric more-prototypes-p
(testsuite)
860 (:documentation
"Returns true if another prototype set exists for the case."))
862 (defgeneric initialize-prototypes
(testsuite)
863 (:documentation
"Creates lists of all prototype sets."))
865 (defgeneric next-prototype
(testsuite)
866 (:documentation
"Ensures that the test environment has the values of the next prototype set."))
868 (defgeneric make-single-prototype
(testsuite))
870 (defgeneric setup-test
(testsuite)
871 (:documentation
"Setup for a test-case. By default it does nothing."))
873 (defgeneric teardown-test
(testsuite)
874 (:documentation
"Tear-down a test-case. By default it does nothing.")
875 (:method-combination progn
:most-specific-first
))
877 (defgeneric testsuite-methods
(testsuite)
878 (:documentation
"Returns a list of the test methods defined for test. I.e.,
879 the methods that should be run to do the tests for this test."))
881 (defgeneric lift-test
(suite name
)
884 (defgeneric do-testing
(testsuite result fn
)
887 (defgeneric end-test
(result case method-name
)
890 (defgeneric initialize-test
(test)
893 (defgeneric run-test-internal
(suite name result
)
896 (defgeneric run-tests-internal
(suite &key result
)
899 (defgeneric start-test
(result case method-name
)
902 (defgeneric test-report-code
(testsuite method
)
905 (defgeneric testsuite-p
(thing)
906 (: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."))
908 (defgeneric testsuite-name-
>gf
(case name
)
911 (defgeneric testsuite-name-
>method
(class name
)
914 (defgeneric flet-test-function
(testsuite function-name
&rest args
)
917 (defmethod setup-test :before
((test test-mixin
))
918 (setf *test-scratchpad
* nil
919 (current-step test
) :test-setup
))
921 (defmethod setup-test ((test test-mixin
))
924 (defmethod teardown-test progn
((test test-mixin
))
927 (defmethod teardown-test :around
((test test-mixin
))
928 (setf (current-step test
) :test-teardown
)
931 (defmethod initialize-test ((test test-mixin
))
934 (defmethod initialize-test :before
((test test-mixin
))
936 (initialize-prototypes test
)
937 (next-prototype test
))
939 (defmethod initialize-instance :after
((testsuite test-mixin
) &rest initargs
940 &key
&allow-other-keys
)
941 (when (null (testsuite-name testsuite
))
942 (setf (slot-value testsuite
'name
)
943 (symbol-name (type-of testsuite
))))
944 ;; FIXME - maybe remove LIFT standard arguments?
945 (setf (suite-initargs testsuite
) initargs
))
947 (defmethod print-object ((tc test-mixin
) stream
)
948 (print-unreadable-object (tc stream
:identity t
:type t
)
949 (format stream
"~a" (testsuite-name tc
))))
951 ;;; ---------------------------------------------------------------------------
953 ;;; ---------------------------------------------------------------------------
955 (defvar *current-definition
* nil
956 "An associative-container which saves interesting information about
957 the thing being defined.")
959 (defun initialize-current-definition ()
960 (setf *current-definition
* nil
))
962 (defun set-definition (name value
)
963 (let ((current (assoc name
*current-definition
*)))
965 (setf (cdr current
) value
)
966 (push (cons name value
) *current-definition
*)))
970 (defun def (name &optional
(definition *current-definition
*))
971 (when definition
(cdr (assoc name definition
))))
973 (defun (setf def
) (value name
)
974 (set-definition name value
))
976 (defvar *code-blocks
* nil
)
978 (defstruct (code-block (:type list
) (:conc-name nil
))
979 block-name
(priority 0) filter code operate-when
)
981 (defgeneric block-handler
(name value
)
983 (:method
((name t
) (value t
))
984 (error "Unknown clause: ~A" name
)))
986 (defun add-code-block (name priority operate-when filter handler code
)
987 (let ((current (assoc name
*code-blocks
*))
988 (value (make-code-block
989 :operate-when operate-when
995 (setf (cdr current
) value
)
996 (push (cons name value
) *code-blocks
*))
998 `(defmethod block-handler ((name (eql ',name
)) value
)
999 (declare (ignorable value
))
1001 (setf *code-blocks
* (sort *code-blocks
* #'<
1002 :key
(lambda (name.cb
)
1003 (priority (cdr name.cb
))))))
1005 (defmacro with-test-slots
(&body body
)
1006 `(symbol-macrolet ((lift-result (getf (test-data *current-test
*) :result
)))
1008 ,(mapcar #'(lambda (local)
1009 `(,local
(test-environment-value ',local
)))
1010 (test-slots (def :testsuite-name
)))
1012 ,(mapcar (lambda (spec)
1013 (destructuring-bind (name arglist
) spec
1015 `(flet-test-function
1016 *current-test
* ',',name
,,@arglist
))))
1017 (def :function-specs
))
1020 (defvar *deftest-clauses
*
1021 '(:setup
:teardown
:test
:documentation
:tests
:export-p
:export-slots
1022 :run-setup
:dynamic-variables
:equality-test
:categories
:function
))
1024 (defmacro deftest
(testsuite-name superclasses slots
&rest
1025 clauses-and-options
)
1026 "The `deftest` form is obsolete, see [deftestsuite][]."
1028 (warn "Deftest is obsolete, use deftestsuite instead.")
1029 `(deftestsuite ,testsuite-name
,superclasses
,slots
,@clauses-and-options
))
1031 (setf *code-blocks
* nil
)
1035 (lambda () (or (def :setup
) (def :direct-slot-names
)))
1036 '((setf (def :setup
) (cleanup-parsed-parameter value
)))
1037 'build-setup-test-method
)
1040 :teardown
100 :methods
1041 (lambda () (or (def :teardown
) (def :direct-slot-names
)))
1042 '((setf (def :teardown
) (cleanup-parsed-parameter value
)))
1043 'build-test-teardown-method
)
1046 :function
0 :methods
1047 (lambda () (def :functions
))
1048 '((push value
(def :functions
)))
1049 'build-test-local-functions
)
1052 :documentation
0 :class-def
1054 '((setf (def :documentation
) (first value
)))
1058 :export-p
0 :class-def
1060 '((setf (def :export-p
) (first value
)))
1064 :export-slots
0 :class-def
1066 '((setf (def :export-slots
) (first value
)))
1070 :run-setup
0 :class-def
1072 '((push (first value
) (def :default-initargs
))
1073 (push :run-setup
(def :default-initargs
))
1074 (setf (def :run-setup
) (first value
)))
1078 :equality-test
0 :methods
1079 (lambda () (def :equality-test
))
1080 '((setf (def :equality-test
) (cleanup-parsed-parameter value
)))
1081 'build-test-equality-test
)
1084 :log-file
0 :class-def
1086 '((push (first value
) (def :default-initargs
))
1087 (push :log-file
(def :default-initargs
)))
1091 :dynamic-variables
0 :class-def
1093 '((setf (def :direct-dynamic-variables
) value
))
1097 :categories
0 :class-def
1099 '((push value
(def :categories
)))
1103 :default-initargs
1 :class-def
1104 (lambda () (def :default-initargs
))
1105 '((dolist (x (reverse (cleanup-parsed-parameter value
)))
1106 (push x
(def :default-initargs
))))
1109 (defmacro deftestsuite
(testsuite-name superclasses slots
&rest
1110 clauses-and-options
)
1112 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.
1114 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.
1116 Slots are specified as in defclass with the following additions:
1118 * 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)`.
1119 * 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
1121 (deftestsuite my-test ()
1124 then `my-slot` will be initialized to 23 during test setup.
1126 Test options are one of :setup, :teardown, :test, :tests, :documentation, :export-p, :dynamic-variables, :export-slots, :function, :categories, :run-setup, or :equality-test.
1128 * :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.
1130 * :documentation - a string specifying any documentation for the test. Should only be specified once.
1132 * :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.
1134 * :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.
1136 * :export-p - If true, the testsuite name will be exported from the current package. Should only be specified once.
1138 * :export-slots - if true, any slots specified in the test suite will be exported from the current package. Should only be specified once.
1140 * :function - creates a locally accessible function for this test suite. May be specified multiple times.
1142 * :run-setup - specify when to run the setup code for this test suite. Allowed values are
1144 * :once-per-test-case or t (the default)
1149 :run-setup is handy when a testsuite has a time consuming setup phase that you do not want to repeat for every test.
1151 * :setup - a list of forms to be evaluated before each test case is run. Should only be specified once.
1153 * :teardown - a list of forms to be evaluated after each test case is run. Should only be specified once.
1155 * :test - Define a single test case. Can be specified multiple times.
1157 * :tests - Define multiple test cases for this test suite. Can be specified multiple times.
1162 (let ((test-list nil
)
1165 ;; convert any clause like :setup foo into (:setup foo)
1166 (setf clauses-and-options
1167 (convert-clauses-into-lists clauses-and-options
*deftest-clauses
*))
1168 (initialize-current-definition)
1169 (setf (def :testsuite-name
) testsuite-name
)
1170 (setf (def :superclasses
) (mapcar #'find-testsuite superclasses
))
1171 (setf (def :deftestsuite
) t
)
1172 ;; parse clauses into defs
1173 (loop for clause in clauses-and-options do
1175 (symbol (pushnew clause options
))
1176 (cons (destructuring-bind (kind &rest spec
) clause
1178 (:test
(push (first spec
) test-list
))
1180 (loop for test in spec do
1181 (push test test-list
)))
1182 (t (block-handler kind spec
)))))
1183 (t (error "When parsing ~S" clause
))))
1184 (let ((slot-names nil
) (slot-specs nil
))
1185 (loop for slot in
(if (listp slots
) slots
(list slots
)) do
1186 (push (if (consp slot
) (first slot
) slot
) slot-names
)
1187 (push (parse-brief-slot slot nil nil nil nil
) slot-specs
))
1188 (setf (def :slot-specs
) (nreverse slot-specs
)
1189 (def :direct-slot-names
) (nreverse slot-names
)
1190 (def :slots-parsed
) t
))
1191 ;;?? issue 27: breaks 'encapsulation' of code-block mechanism
1192 (setf (def :function-specs
)
1193 (loop for spec in
(def :functions
) collect
1194 (destructuring-bind (name arglist
&body body
) (first spec
)
1195 (declare (ignore body
))
1196 `(,name
,arglist
))))
1198 (empty-test-tables testsuite-name
)
1199 (compute-superclass-inheritence)
1201 (setf *testsuite-test-count
* 0)
1202 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
1203 (eval-when (:compile-toplevel
)
1204 (push ',return
*test-is-being-compiled?
*))
1205 (eval-when (:load-toplevel
)
1206 (push ',return
*test-is-being-loaded?
*))
1207 (eval-when (:execute
)
1208 (push ',return
*test-is-being-executed?
*))
1209 ;; remove previous methods (do this _before_ we define the class)
1210 (unless (or *test-is-being-compiled?
*
1211 *test-is-being-loaded?
*)
1213 (print (list :cle
*test-is-being-compiled?
*
1214 *test-is-being-loaded?
*
1215 *test-is-being-loaded?
*))
1216 (remove-previous-definitions ',(def :testsuite-name
)))
1219 (let ((*test-is-being-defined?
* t
))
1220 (setf *current-test-case-name
* nil
)
1221 (setf *current-testsuite-name
* ',(def :testsuite-name
)
1222 (test-slots ',(def :testsuite-name
))
1224 (testsuite-dynamic-variables ',(def :testsuite-name
))
1225 ',(def :dynamic-variables
)
1226 ;;?? issue 27: breaks 'encapsulation' of code-block
1228 (testsuite-function-specs ',(def :testsuite-name
))
1229 ',(def :function-specs
))
1230 ,@(when (def :export-p
)
1231 `((export '(,(def :testsuite-name
)))))
1232 ,@(when (def :export-slots?
)
1233 `((export ',(def :direct-slot-names
))))
1234 ;; make a place to save test-case information
1235 (empty-test-tables ',(def :testsuite-name
))
1238 ,@(build-initialize-test-method)
1239 ,@(loop for
(nil . block
) in
*code-blocks
*
1242 (eq (operate-when block
) :methods
)
1243 (or (not (filter block
))
1244 (funcall (filter block
)))) collect
1245 (funcall (code block
)))
1246 ,@(when (def :dynamic-variables
)
1247 `((defmethod do-testing :around
1248 ((suite ,(def :testsuite-name
)) result fn
)
1249 (declare (ignore result fn
))
1250 (cond ((done-dynamics? suite
)
1253 (setf (slot-value suite
'done-dynamics?
) t
)
1254 (let* (,@(build-dynamics))
1255 (call-next-method)))))))
1258 `((let ((*test-evaluate-when-defined?
* nil
))
1259 ,@(loop for test in
(nreverse test-list
) collect
1260 `(addtest (,(def :testsuite-name
))
1262 (setf *testsuite-test-count
* nil
))))
1263 ,(if (and test-list
*test-evaluate-when-defined?
*)
1264 `(unless (or *test-is-being-compiled?
*
1265 *test-is-being-loaded?
*)
1266 (let ((*test-break-on-errors?
* *test-break-on-errors?
*))
1267 (run-tests :suite
',testsuite-name
)))
1268 `(find-class ',testsuite-name
)))
1270 (setf *test-is-being-compiled?
*
1271 (remove ',return
*test-is-being-compiled?
*))
1272 (setf *test-is-being-loaded?
*
1273 (remove ',return
*test-is-being-loaded?
*))
1274 (setf *test-is-being-executed?
*
1275 (remove ',return
*test-is-being-executed?
*)))))))
1277 (defun compute-superclass-inheritence ()
1278 ;;?? issue 27: break encapsulation of code blocks
1279 ;;?? we assume that we won't have too deep a hierarchy or too many
1280 ;; dv's or functions so that having lots of duplicate names is OK
1282 (dynamic-variables nil
)
1283 (function-specs nil
))
1284 (dolist (super (def :superclasses
))
1285 (cond ((find-testsuite super
)
1286 (setf slots
(append slots
(test-slots super
))
1288 (append dynamic-variables
1289 (testsuite-dynamic-variables super
))
1291 (append function-specs
1292 (testsuite-function-specs super
))))
1294 (error 'testsuite-not-defined
:testsuite-name super
))))
1295 (setf (def :slot-names
)
1296 (remove-duplicates (append (def :direct-slot-names
) slots
))
1297 (def :dynamic-variables
)
1299 (append (def :direct-dynamic-variables
) dynamic-variables
))
1300 (def :function-specs
)
1302 (append (def :function-specs
) function-specs
)))
1303 (setf (def :superclasses
)
1304 (loop for class in
(def :superclasses
)
1305 unless
(some (lambda (oter)
1306 (and (not (eq class oter
))
1307 (member class
(superclasses oter
))))
1308 (def :superclasses
)) collect
1311 (defmacro addtest
(name &body test
)
1312 "Adds a single new test-case to the most recently defined testsuite."
1319 (looks-like-suite-name (looks-like-suite-name-p name
))
1320 (looks-like-code (looks-like-code-p name
)))
1321 (cond ((and looks-like-suite-name looks-like-code
)
1322 (error "Can't disambiguate suite name from possible code."))
1323 (looks-like-suite-name
1325 (setf (def :testsuite-name
) (first name
)
1327 name nil body test
))
1329 ;; the 'name' is really part of the test...
1330 (setf body
(cons name test
))))
1331 (unless (def :testsuite-name
)
1332 (when *current-testsuite-name
*
1333 (setf (def :testsuite-name
) *current-testsuite-name
*)))
1334 (unless (def :testsuite-name
)
1335 (signal-lift-error 'add-test
+lift-no-current-test-class
+))
1336 (unless (or (def :deftestsuite
)
1337 (find-testsuite (def :testsuite-name
)))
1338 (signal-lift-error 'add-test
+lift-test-class-not-found
+
1339 (def :testsuite-name
)))
1340 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
1341 (eval-when (:compile-toplevel
)
1342 (push ',return
*test-is-being-compiled?
*))
1343 (eval-when (:load-toplevel
)
1344 (push ',return
*test-is-being-loaded?
*))
1345 (eval-when (:execute
)
1346 (push ',return
*test-is-being-executed?
*))
1348 (let ((*test-is-being-defined?
* t
))
1349 ,(build-test-test-method (def :testsuite-name
) body options
)
1350 (setf *current-testsuite-name
* ',(def :testsuite-name
))
1351 (if *test-evaluate-when-defined?
*
1352 (unless (or *test-is-being-compiled?
*
1353 *test-is-being-loaded?
*)
1354 (let ((*test-break-on-errors?
* (testing-interactively-p)))
1358 (setf *test-is-being-compiled?
*
1359 (remove ',return
*test-is-being-compiled?
*)
1360 *test-is-being-loaded?
*
1361 (remove ',return
*test-is-being-loaded?
*)
1362 *test-is-being-executed?
*
1363 (remove ',return
*test-is-being-executed?
*))))))
1365 (defun looks-like-suite-name-p (form)
1368 (find-testsuite (first form
))
1369 (property-list-p (rest form
))))
1371 (defun property-list-p (form)
1376 for want-keyword?
= t then
(not want-keyword?
) do
1377 (when (and want-keyword?
(not (keywordp x
)))
1378 (return-from check-it nil
))
1379 (setf even?
(not even?
)))
1380 (return-from check-it even?
)))))
1383 (property-list-p '(:a
:b
))
1384 (property-list-p '(:a
2 :b
3 :c
5 :d
8))
1385 (property-list-p nil
)
1388 (property-list-p '(3))
1389 (property-list-p '(3 :a
))
1390 (property-list-p '(:a
3 :b
))
1393 (defun looks-like-code-p (name)
1394 (declare (ignore name
))
1398 (defun remove-test (&key
(test-case *current-test-case-name
*)
1399 (suite *current-testsuite-name
*))
1400 (assert suite nil
"Test suite could not be determined.")
1401 (assert test-case nil
"Test-case could not be determined.")
1402 (setf (testsuite-tests suite
)
1403 (remove test-case
(testsuite-tests suite
))))
1405 (defun run-test (&rest args
1406 &key
(test-case *current-test-case-name
*)
1407 (name test-case name-supplied-p
)
1408 (suite *current-testsuite-name
*)
1409 (break-on-errors?
*test-break-on-errors?
*)
1410 (break-on-failures?
*test-break-on-failures?
*)
1411 (do-children?
*test-do-children?
*)
1414 "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."
1415 (declare (ignore profile
))
1416 (when name-supplied-p
1417 (setf test-case name
))
1418 (assert suite nil
"Test suite could not be determined.")
1419 (assert test-case nil
"Test-case could not be determined.")
1420 (let* ((*test-break-on-errors?
* break-on-errors?
)
1421 (*test-break-on-failures?
* break-on-failures?
)
1422 (*test-do-children?
* do-children?
)
1423 (*current-test
* (make-testsuite suite args
)))
1425 (setf result
(make-test-result suite
:single
)))
1427 (let ((*current-test-case-name
* (find-test-case suite test-case
))
1428 (*current-testsuite-name
* suite
))
1429 (do-testing-in-environment
1430 *current-test
* result
1433 *current-test
* *current-test-case-name
* result
)))
1434 (setf *test-result
* result
))
1435 (setf *current-test-case-name
* (find-test-case suite test-case
)
1436 *current-testsuite-name
* suite
))))
1438 (defun make-testsuite (suite args
)
1439 (let ((make-instance-args nil
))
1440 (loop for keyword in
*make-testsuite-arguments
* do
1441 (when (member keyword args
)
1442 (push keyword make-instance-args
)
1443 (push (getf args keyword
) make-instance-args
)))
1444 (apply #'make-instance
(find-testsuite suite
)
1445 (nreverse make-instance-args
))))
1448 (defmethod do-testing-in-environment :around
((suite test-mixin
) result fn
)
1449 (declare (ignore fn
))
1450 (testsuite-setup suite result
)
1455 ((not (more-prototypes-p suite
)) result
)
1457 (handler-bind ((warning #'muffle-warning
)
1458 ; ignore warnings...
1461 (report-test-problem
1462 'testsuite-error result suite
1463 *current-test-case-name
* condition
1464 :backtrace
(get-backtrace condition
))
1465 (if *test-break-on-errors?
*
1466 (invoke-debugger condition
)
1468 (let ((*lift-equality-test
* (equality-test suite
)))
1469 (initialize-test suite
)
1470 (call-next-method)))
1471 (ensure-failed (condition)
1472 (report-test-problem
1473 'testsuite-failure result suite
1474 *current-test-case-name
* condition
))
1475 (retry-test () :report
"Retry the test."
1479 (testsuite-teardown suite result
))
1482 (defmethod do-testing-in-environment :around
((suite test-mixin
) result fn
)
1483 (declare (ignore fn
))
1487 (handler-bind ((warning #'muffle-warning
)
1488 ; ignore warnings...
1491 (report-test-problem
1492 'testsuite-error result suite
1493 *current-test-case-name
* condition
1494 :backtrace
(get-backtrace condition
))
1495 (if *test-break-on-errors?
*
1496 (invoke-debugger condition
)
1499 (let ((*lift-equality-test
* (equality-test suite
)))
1500 (testsuite-setup suite result
)
1502 ((not (more-prototypes-p suite
)) result
)
1503 (initialize-test suite
)
1504 (call-next-method)))
1506 (testsuite-teardown suite result
)))
1507 (ensure-failed (condition)
1508 (report-test-problem
1509 'testsuite-failure result suite
1510 *current-test-case-name
* condition
))
1511 (retry-test () :report
"Retry the test."
1516 (defmethod do-testing-in-environment ((suite test-mixin
) result fn
)
1517 (do-testing suite result fn
)
1520 (defmethod do-testing ((suite test-mixin
) result fn
)
1524 (defmethod run-tests-internal ((suite symbol
) &rest args
&key
&allow-other-keys
)
1525 (let ((*current-test
* (make-testsuite suite args
)))
1526 (remf args
:profile
)
1527 (apply #'run-tests-internal
*current-test
* args
)))
1529 (defmethod run-tests-internal
1530 ((case test-mixin
) &key
1531 (result (make-test-result (class-of case
) :multiple
))
1532 (do-children?
*test-do-children?
*))
1533 (let ((*test-do-children?
* do-children?
))
1534 (do-testing-in-environment
1537 (testsuite-run case result
)))
1538 (setf *test-result
* result
)))
1540 (defun run-tests (&rest args
&key
1542 (break-on-errors?
*test-break-on-errors?
*)
1543 (break-on-failures?
*test-break-on-failures?
*)
1545 (dribble *lift-dribble-pathname
*)
1548 (do-children?
*test-do-children?
*)
1551 "Run all of the tests in a suite. Arguments are :suite, :result,
1552 :do-children? and :break-on-errors?"
1553 (let ((args-copy (copy-list args
)))
1555 (remf args
:break-on-errors?
)
1556 (remf args
:break-on-failures?
)
1557 (remf args
:run-setup
)
1558 (remf args
:dribble
)
1560 (remf args
:report-pathname
)
1561 (remf args
:do-children?
)
1562 (remf args
:tests-to-skip
)
1563 (let* ((result (or result
1564 (apply #'make-test-result
1565 (or suite config
) :multiple args
)))
1566 (*lift-report-pathname
*
1567 (cond ((null report-pathname
) nil
)
1568 ((eq report-pathname t
)
1569 (report-summary-pathname))))
1570 (*test-do-children?
* do-children?
)
1571 (report-pathname *lift-report-pathname
*))
1572 (when report-pathname
1573 (ensure-directories-exist report-pathname
)
1574 (write-report-header report-pathname result args-copy
))
1575 (cond ((and suite config
)
1576 (error "Specify either configuration file or test suite
1579 (run-tests-from-file config
))
1580 ((or suite
(setf suite
*current-testsuite-name
*))
1581 (let* ((*test-break-on-errors?
* break-on-errors?
)
1582 (*test-break-on-failures?
* break-on-failures?
)
1587 :if-does-not-exist
:create
1588 :if-exists
*lift-if-dribble-exists
*)))
1589 (*standard-output
* (maybe-add-dribble
1590 *lift-standard-output
* dribble-stream
))
1591 (*error-output
* (maybe-add-dribble
1592 *error-output
* dribble-stream
))
1593 (*debug-io
* (maybe-add-dribble
1594 *debug-io
* dribble-stream
)))
1596 (dolist (testsuite (if (consp suite
) suite
(list suite
)))
1597 (let ((*current-testsuite-name
* testsuite
))
1598 (apply #'run-tests-internal testsuite
1599 :result result
:profile profile args
))
1600 (setf *current-testsuite-name
* testsuite
))
1602 (when dribble-stream
1603 (close dribble-stream
)))
1605 (setf (tests-run result
) (reverse (tests-run result
)))
1606 (when report-pathname
1607 (write-report-footer report-pathname result
))
1610 (error "There is not a current test suite and neither suite
1611 nor configuration file options were specified."))))))
1613 (defun maybe-add-dribble (stream dribble-stream
)
1615 (values (make-broadcast-stream stream dribble-stream
) t
)
1616 (values stream nil
)))
1618 (defun skip-test-case-p (result suite-name test-case-name
)
1619 (find-if (lambda (skip-datum)
1620 (and (eq suite-name
(car skip-datum
))
1621 (or (null (cdr skip-datum
))
1622 (eq test-case-name
(cdr skip-datum
)))))
1623 (tests-to-skip result
)))
1625 (defmethod skip-test-case (result suite-name test-case-name
)
1626 (declare (ignore result suite-name test-case-name
))
1629 (defun skip-test-suite-children-p (result testsuite
)
1630 (let ((suite-name (class-name (class-of testsuite
))))
1631 (find-if (lambda (skip-datum)
1632 (and (eq suite-name
(car skip-datum
))
1633 (eq :including-children
(cdr skip-datum
))))
1634 (tests-to-skip result
))))
1636 (defmethod testsuite-run ((testsuite test-mixin
) (result test-result
))
1637 (unless (start-time result
)
1638 (setf (start-time result
) (get-internal-real-time)
1639 (start-time-universal result
) (get-universal-time)))
1641 (let* ((methods (testsuite-methods testsuite
))
1642 (suite-name (class-name (class-of testsuite
)))
1643 (*current-testsuite-name
* suite-name
))
1644 (loop for method in methods do
1645 (if (skip-test-case-p result suite-name method
)
1646 (skip-test-case result suite-name method
)
1647 (run-test-internal testsuite method result
)))
1648 (when (and *test-do-children?
*
1649 (not (skip-test-suite-children-p result testsuite
)))
1650 (loop for subclass in
(direct-subclasses (class-of testsuite
))
1651 when
(and (testsuite-p subclass
)
1652 (not (member (class-name subclass
)
1653 (suites-run result
)))) do
1654 (run-tests-internal (class-name subclass
)
1656 (setf (end-time result
) (get-universal-time))))
1658 (defmethod more-prototypes-p ((testsuite test-mixin
))
1659 (not (null (prototypes testsuite
))))
1661 (defmethod initialize-prototypes ((testsuite test-mixin
))
1662 (setf (prototypes testsuite
)
1663 (list (make-single-prototype testsuite
))))
1665 (defmethod make-single-prototype ((testsuite test-mixin
))
1668 (defmethod initialize-prototypes :around
((suite test-mixin
))
1669 (unless (prototypes-initialized? suite
)
1670 (setf (slot-value suite
'prototypes-initialized?
) t
)
1671 (call-next-method)))
1673 (defmethod next-prototype ((testsuite test-mixin
))
1674 (setf (current-values testsuite
) (first (prototypes testsuite
))
1675 (prototypes testsuite
) (rest (prototypes testsuite
)))
1676 (dolist (key.value
(current-values testsuite
))
1677 (setf (test-environment-value (car key.value
)) (cdr key.value
))))
1679 (defmethod run-test-internal ((suite test-mixin
) (name symbol
) result
)
1680 (when (and *test-print-test-case-names
*
1681 (eq (test-mode result
) :multiple
))
1682 (print-lift-message "~& run: ~a" name
))
1683 (let ((*current-test-case-name
* name
))
1687 (handler-bind ((warning #'muffle-warning
)
1688 ; ignore warnings...
1691 (report-test-problem
1692 'test-error result suite
1693 *current-test-case-name
* condition
1694 :backtrace
(get-backtrace condition
))
1695 (if (and *test-break-on-errors?
*
1696 (not (testcase-expects-error-p)))
1697 (invoke-debugger condition
)
1699 (setf (current-method suite
) name
)
1700 (start-test result suite name
)
1704 (setf (current-step suite
) :testing
)
1706 (getf (test-data suite
) :seconds
)
1707 (getf (test-data suite
) :conses
)
1708 (lift-test suite name
))
1709 (check-for-surprises suite
))
1711 (teardown-test suite
)
1712 (end-test result suite name
)))
1713 (ensure-failed (condition)
1714 (report-test-problem
1715 'test-failure result suite
1716 *current-test-case-name
* condition
)
1717 (if (and *test-break-on-failures?
*
1718 (not (testcase-expects-failure-p)))
1719 (invoke-debugger condition
)
1721 (retry-test () :report
"Retry the test."
1724 (push (list (type-of suite
) *current-test-case-name
* (test-data suite
))
1726 (when *lift-report-pathname
*
1727 (let ((current (first (tests-run result
))))
1728 (summarize-single-test
1729 :save
(first current
) (second current
) (third current
)
1730 :stream
*lift-report-pathname
*))))
1731 (setf *current-test-case-name
* name
1732 *test-result
* result
))
1734 (defun testcase-expects-error-p (&optional
(test *current-test
*))
1735 (let* ((options (getf (test-data test
) :options
)))
1736 (second (member :expected-error options
))))
1738 (defun testcase-expects-failure-p (&optional
(test *current-test
*))
1739 (let* ((options (getf (test-data test
) :options
)))
1740 (second (member :expected-failure options
))))
1742 (defun testcase-expects-problem-p (&optional
(test *current-test
*))
1743 (let* ((options (getf (test-data test
) :options
)))
1744 (second (member :expected-problem options
))))
1746 (defun check-for-surprises (testsuite)
1747 (let* ((expected-failure-p (testcase-expects-failure-p testsuite
))
1748 (expected-error-p (testcase-expects-error-p testsuite
))
1749 (expected-problem-p (testcase-expects-problem-p testsuite
))
1753 (setf (slot-value testsuite
'expected-failure-p
) expected-failure-p
))
1755 (setf (slot-value testsuite
'expected-error-p
) expected-error-p
))
1757 (setf (slot-value testsuite
'expected-problem-p
) expected-problem-p
)))
1759 ((expected-failure-p testsuite
)
1761 (make-condition 'unexpected-success-failure
1763 :expected-more
(expected-failure-p testsuite
))))
1764 ((expected-error-p testsuite
)
1766 (make-condition 'unexpected-success-failure
1768 :expected-more
(expected-error-p testsuite
))))
1769 ((expected-problem-p testsuite
)
1771 (make-condition 'unexpected-success-failure
1773 :expected-more
(expected-problem-p testsuite
)))))
1775 (if (find-restart 'ensure-failed
)
1776 (invoke-restart 'ensure-failed condition
)
1777 (warn condition
)))))
1779 (defun report-test-problem (problem-type result suite method condition
1784 (declare (ignore docs option
))
1785 (cond ((and (eq problem-type
'test-failure
)
1786 (not (typep condition
'unexpected-success-failure
))
1787 (testcase-expects-failure-p suite
))
1788 (setf problem-type
'test-expected-failure
1789 option
:expected-failure
))
1790 ((and (eq problem-type
'test-error
)
1791 (testcase-expects-error-p suite
))
1792 (setf problem-type
'test-expected-error
1793 option
:expected-error
))
1794 ((and (or (eq problem-type
'test-failure
)
1795 (eq problem-type
'test-error
))
1796 (testcase-expects-problem-p suite
))
1797 (setf problem-type
(or (and (eq problem-type
'test-failure
)
1798 'test-expected-failure
)
1799 (and (eq problem-type
'test-error
)
1800 'test-expected-error
))
1801 option
:expected-problem
)))
1802 (let ((problem (apply #'make-instance problem-type
1805 :test-condition condition
1806 :test-step
(current-step suite
) args
)))
1807 (setf (getf (test-data suite
) :problem
) problem
)
1809 ((or test-failure testsuite-failure
) (push problem
(failures result
)))
1810 (test-expected-failure (push problem
(expected-failures result
)))
1811 ((or test-error testsuite-error
) (push problem
(errors result
)))
1812 (test-expected-error (push problem
(expected-errors result
))))
1815 ;;; ---------------------------------------------------------------------------
1816 ;;; test-result and printing
1817 ;;; ---------------------------------------------------------------------------
1819 (defun get-test-print-length ()
1820 (let ((foo *test-print-length
*))
1821 (if (eq foo
:follow-print
) *print-length
* foo
)))
1823 (defun get-test-print-level ()
1824 (let ((foo *test-print-level
*))
1825 (if (eq foo
:follow-print
) *print-level
* foo
)))
1827 (defmethod start-test ((result test-result
) (suite test-mixin
) name
)
1828 (declare (ignore name
))
1829 (setf (current-step suite
) :start-test
1831 `(:start-time
,(get-internal-real-time)
1832 :start-time-universal
,(get-universal-time))))
1834 (defmethod end-test ((result test-result
) (suite test-mixin
) name
)
1835 (declare (ignore name
))
1836 (setf (current-step suite
) :end-test
1837 (getf (test-data suite
) :end-time
) (get-internal-real-time)
1838 (end-time result
) (get-internal-real-time)
1839 (getf (test-data suite
) :end-time-universal
) (get-universal-time)
1840 (end-time-universal result
) (get-universal-time)))
1842 (defun make-test-result (for test-mode
&rest args
)
1843 (apply #'make-instance
'test-result
1845 :test-mode test-mode
1848 (defun testing-interactively-p ()
1851 (defmethod print-object ((tr test-result
) stream
)
1852 (let ((complete-success?
(and (null (errors tr
))
1853 (null (failures tr
))
1854 (null (expected-failures tr
))
1855 (null (expected-errors tr
)))))
1856 (let* ((*print-level
* (get-test-print-level))
1857 (*print-length
* (get-test-print-length))
1858 (non-failure-failures
1861 (member (class-of (test-condition failure
))
1862 (subclasses 'unexpected-success-failure
:proper? nil
)))
1863 (expected-failures tr
)))
1864 (expected-failures (- (length (expected-failures tr
))
1865 non-failure-failures
)))
1866 (print-unreadable-object (tr stream
)
1867 (cond ((null (tests-run tr
))
1868 (format stream
"~A: no tests defined" (results-for tr
)))
1869 ((eq (test-mode tr
) :single
)
1870 (cond ((test-interactive? tr
)
1872 (cond (complete-success?
1873 (format stream
"Test passed"))
1875 (format stream
"Error during testing"))
1876 ((expected-errors tr
)
1877 (format stream
"Expected error during testing"))
1879 (format stream
"Test failed"))
1880 ((plusp non-failure-failures
)
1881 (format stream
"Test succeeded unexpectedly"))
1883 (format stream
"Test failed expectedly"))))
1886 (format stream
"~A.~A ~A"
1888 (first (first (tests-run tr
)))
1889 (cond (complete-success?
1895 (when (or (expected-errors tr
) (expected-failures tr
))
1896 (format stream
"(~[~:;, ~:*~A expected failure~:P~]~[~:;, ~:*~A succeeded unexpectedly~]~[~:;, ~:*~A expected error~:P~])"
1897 expected-failures non-failure-failures
1898 (expected-errors tr
))))))
1900 ;; multiple tests run
1901 (format stream
"Results for ~A " (results-for tr
))
1902 (if complete-success?
1903 (format stream
"[~A Successful test~:P]"
1904 (length (tests-run tr
)))
1905 (format stream
"~A Test~:P~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Error~:P~]~[~:;, ~:*~A Expected failure~:P~]~[~:;, ~:*~A Expected error~:P~]"
1906 (length (tests-run tr
))
1907 (length (failures tr
))
1908 (length (errors tr
))
1909 (length (expected-failures tr
))
1910 (length (expected-errors tr
))))))
1911 ;; note that suites with no tests think that they are completely
1912 ;; successful. Optimistic little buggers, huh?
1913 (when (and (not complete-success?
) *test-describe-if-not-successful?
*)
1914 (format stream
"~%")
1915 (print-test-result-details stream tr t t
))))))
1917 (defmethod describe-object ((result test-result
) stream
)
1918 (describe-test-result result stream
))
1920 (defmethod describe-test-result (result stream
1922 (show-details-p *test-show-details-p
*)
1923 (show-expected-p *test-show-expected-p
*)
1924 (show-code-p *test-show-code-p
*))
1925 (let* ((number-of-failures (length (failures result
)))
1926 (number-of-errors (length (errors result
)))
1927 (number-of-expected-errors (length (expected-errors result
)))
1928 (non-failure-failures
1931 (member (class-of (test-condition failure
))
1932 (subclasses 'unexpected-success-failure
:proper? nil
)))
1933 (expected-failures result
)))
1934 (number-of-expected-failures (- (length (expected-failures result
))
1935 non-failure-failures
)))
1936 (unless *test-is-being-defined?
*
1937 (format stream
"~&Test Report for ~A: ~D test~:P run"
1938 (results-for result
) (length (tests-run result
))))
1939 (flet ((show-details ()
1940 (when show-details-p
1941 (format stream
"~%~%")
1942 (print-test-result-details
1943 stream result show-expected-p show-code-p
))))
1944 (let* ((*print-level
* (get-test-print-level))
1945 (*print-length
* (get-test-print-length)))
1946 (cond ((or (failures result
) (errors result
)
1947 (expected-failures result
) (expected-errors result
))
1948 (format stream
"~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Expected failure~:P~]~[~:;, ~:*~A Successful Surprise~:P~]~[~:;, ~:*~A Error~:P~]~[~:;, ~:*~A Expected error~:P~]."
1950 number-of-expected-failures
1951 non-failure-failures
1953 number-of-expected-errors
)
1955 ((or (expected-failures result
) (expected-errors result
))
1956 (format stream
", all passed *~[~:;, ~:*~A Expected failure~:P~]~[~:;, ~:*~A Expected error~:P~])."
1957 number-of-expected-failures
1958 number-of-expected-errors
)
1961 (unless *test-is-being-defined?
*
1962 (format stream
", all passed!")))))
1965 (defun print-test-result-details (stream result show-expected-p show-code-p
)
1966 (loop for report in
(errors result
) do
1967 (print-test-problem "ERROR : " report stream
1969 (loop for report in
(failures result
) do
1970 (print-test-problem "Failure: " report stream
1972 (when show-expected-p
1973 (loop for report in
(expected-failures result
) do
1974 (print-test-problem "Expected failure: " report stream
1976 (loop for report in
(expected-errors result
) do
1977 (print-test-problem "Expected Error : " report stream
1980 (defun print-test-problem (prefix report stream show-code-p
)
1981 (let* ((suite (testsuite report
))
1982 (method (test-method report
))
1983 (condition (test-condition report
))
1984 (code (test-report-code suite method
))
1985 (testsuite-name method
))
1986 (format stream
"~&~A~(~A : ~A~)" prefix
(type-of suite
) testsuite-name
)
1987 (let ((doc-string (gethash testsuite-name
1988 (test-case-documentation
1989 (class-name (class-of suite
))))))
1991 (format stream
"~&~A" doc-string
)))
1993 (setf code
(with-output-to-string (out)
1994 (pprint code out
))))
1995 (format stream
"~&~< ~@;~
1996 ~@[Condition: ~<~@;~A~:>~]~
1998 ~&~:>" (list (list condition
) code
))))
2001 ;;; ---------------------------------------------------------------------------
2003 ;;; ---------------------------------------------------------------------------
2005 (defclass test-problem-mixin
()
2006 ((testsuite :initform nil
:initarg
:testsuite
:reader testsuite
)
2007 (test-method :initform nil
:initarg
:test-method
:reader test-method
)
2008 (test-condition :initform nil
2009 :initarg
:test-condition
2010 :reader test-condition
)
2011 (test-problem-kind :reader test-problem-kind
:allocation
:class
)
2012 (test-step :initform nil
:initarg
:test-step
:reader test-step
)))
2014 (defmethod print-object ((problem test-problem-mixin
) stream
)
2015 (print-unreadable-object (problem stream
)
2016 (format stream
"TEST-~@:(~A~): ~A in ~A"
2017 (test-problem-kind problem
)
2018 (name (testsuite problem
))
2019 (test-method problem
))))
2021 (defclass generic-problem
(test-problem-mixin)
2022 ((test-problem-kind :initarg
:test-problem-kind
2023 :allocation
:class
)))
2025 (defclass expected-problem-mixin
()
2026 ((documentation :initform nil
2027 :initarg
:documentation
2028 :accessor failure-documentation
)))
2030 (defclass test-expected-failure
(expected-problem-mixin generic-problem
)
2033 :test-problem-kind
"Expected failure"))
2035 (defclass test-failure
(generic-problem)
2038 :test-problem-kind
"failure"))
2040 (defclass test-error-mixin
(generic-problem)
2041 ((backtrace :initform nil
:initarg
:backtrace
:reader backtrace
)))
2043 (defclass test-expected-error
(expected-problem-mixin test-error-mixin
)
2046 :test-problem-kind
"Expected error"))
2048 (defclass test-error
(test-error-mixin)
2051 :test-problem-kind
"Error"))
2053 (defclass testsuite-error
(test-error-mixin)
2056 :test-problem-kind
"Testsuite error"))
2058 (defclass testsuite-failure
(generic-problem)
2061 :test-problem-kind
"Testsuite failure"))
2063 (defmethod test-report-code ((testsuite test-mixin
) (method symbol
))
2064 (let* ((class-name (class-name (class-of testsuite
))))
2066 (test-name->code-table class-name
))))
2068 ;;; ---------------------------------------------------------------------------
2070 ;;; ---------------------------------------------------------------------------
2072 (defun remove-test-methods (test-name)
2074 (length (testsuite-tests test-name
))
2075 (setf (testsuite-tests test-name
) nil
)))
2077 (defun remove-previous-definitions (classname)
2078 "Remove the methods of this class and all its subclasses."
2079 (let ((classes-removed nil
)
2080 (class (find-class classname nil
))
2083 (loop for subclass in
(subclasses class
:proper? nil
) do
2084 (push subclass classes-removed
)
2086 (remove-test-methods (class-name subclass
)))
2088 ;;?? causing more trouble than it solves...??
2089 (setf (find-class (class-name subclass
)) nil
))
2091 (unless (length-1-list-p classes-removed
)
2093 "~&;;; Removed Test suite ~(~A~) and its subclasses (~{~<~s~>~^, ~})."
2096 (mapcar #'class-name classes-removed
))
2098 (unless (zerop removed-count
)
2100 "~&;;; Removed ~D methods from test suite ~(~A~)~@[ and its subclasses~]."
2101 removed-count classname
2102 (not (length-1-list-p classes-removed
)))))))
2104 (defun build-initialize-test-method ()
2105 (let ((initforms nil
)
2107 (slot-specs (def :slot-specs
)))
2108 (loop for slot in slot-specs do
2109 (when (and (member :initform
(rest slot
))
2110 (not (eq :unbound
(getf (rest slot
) :initform
))))
2111 (push (getf (rest slot
) :initform
) initforms
)
2112 (push (first slot
) slot-names
)))
2113 (setf slot-names
(nreverse slot-names
)
2114 initforms
(nreverse initforms
))
2116 `((defmethod make-single-prototype ((testsuite ,(def :testsuite-name
)))
2117 (let ((initargs (suite-initargs testsuite
)))
2120 (when (next-method-p) (call-next-method))
2122 (lambda (slot-name initform
)
2125 ,(intern (symbol-name slot-name
)
2128 slot-names initforms
))
2129 (list ,@(mapcar (lambda (slot-name)
2130 `(cons ',slot-name
,slot-name
))
2131 slot-names
)))))))))))
2133 (defun (setf test-environment-value
) (value name
)
2134 (pushnew (cons name value
) *test-environment
* :test
#'equal
)
2137 (defun test-environment-value (name)
2138 (cdr (assoc name
*test-environment
*)))
2140 (defun remove-from-test-environment (name)
2141 (setf *test-environment
*
2142 (remove name
*test-environment
* :key
#'car
)))
2144 (defun build-test-local-functions ()
2147 (lambda (function-spec)
2148 (destructuring-bind (name arglist
&body body
) (first function-spec
)
2149 `(defmethod flet-test-function ((testsuite ,(def :testsuite-name
))
2150 (function-name (eql ',name
))
2154 `(destructuring-bind ,arglist args
2156 `(progn ,@body
))))))
2159 (defun build-test-equality-test ()
2160 (let ((test-name (def :testsuite-name
))
2161 (equality-test (def :equality-test
)))
2163 (defmethod equality-test ((testsuite ,test-name
))
2166 (defun build-test-teardown-method ()
2167 (let ((test-name (def :testsuite-name
))
2168 (slot-names (def :direct-slot-names
))
2169 (teardown (def :teardown
)))
2171 (unless (consp teardown
)
2172 (setf teardown
(list teardown
)))
2173 (when (length-1-list-p teardown
)
2174 (setf teardown
(list teardown
)))
2175 (when (symbolp (first teardown
))
2176 (setf teardown
(list teardown
))))
2177 (let* ((teardown-code `(,@(when teardown
2178 `((with-test-slots ,@teardown
)))))
2179 (test-code `(,@teardown-code
2180 ,@(mapcar (lambda (slot)
2181 `(remove-from-test-environment ',slot
))
2184 ,@(when teardown-code
2185 `((defmethod teardown-test progn
((testsuite ,test-name
))
2186 (when (run-teardown-p testsuite
:test-case
)
2188 ,@(when teardown-code
2189 `((defmethod testsuite-teardown ((testsuite ,test-name
)
2190 (result test-result
))
2191 (when (run-teardown-p testsuite
:testsuite
)
2194 (defun build-setup-test-method ()
2195 (let ((test-name (def :testsuite-name
))
2196 (setup (def :setup
)))
2198 (unless (consp setup
)
2199 (setf setup
(list setup
)))
2200 (when (length-1-list-p setup
)
2201 (setf setup
(list setup
)))
2202 (when (symbolp (first setup
))
2203 (setf setup
(list setup
)))
2204 (let ((code `((with-test-slots ,@setup
))))
2206 (defmethod setup-test :after
((testsuite ,test-name
))
2209 (defmethod setup-test :around
((test test-mixin
))
2210 (when (run-setup-p test
)
2212 (setf (slot-value test
'done-setup?
) t
)))
2214 (defun run-setup-p (testsuite)
2215 (case (run-setup testsuite
)
2216 (:once-per-session
(error "not implemented"))
2217 (:once-per-suite
(not (done-setup? testsuite
)))
2218 ((:once-per-test-case t
) t
)
2220 (t (error "Don't know about ~s for run-setup" (run-setup testsuite
)))))
2222 (defun run-teardown-p (testsuite when
)
2225 (ecase (run-setup testsuite
)
2226 (:once-per-session nil
)
2227 (:once-per-suite nil
)
2228 ((:once-per-test-case t
) t
)
2229 ((:never nil
) nil
)))
2231 (ecase (run-setup testsuite
)
2232 (:once-per-session nil
)
2234 ((:once-per-test-case t
) nil
)
2235 ((:never nil
) nil
)))))
2237 (defun build-test-test-method (test-class test-body options
)
2238 (multiple-value-bind (test-name body documentation name-supplied?
)
2239 (parse-test-body test-body
)
2240 (declare (ignorable name-supplied?
))
2241 (unless (consp (first body
))
2242 (setf body
(list body
)))
2244 (setf (gethash ',test-name
(test-name->code-table
',test-class
)) ',body
2245 (gethash ',body
(test-code->name-table
',test-class
)) ',test-name
)
2246 ,(when documentation
2247 `(setf (gethash ',test-name
(test-case-documentation ',test-class
))
2250 ,@(when name-supplied?
2251 `((ccl:record-source-file
',test-name
'test-case
)))
2252 (unless (find ',test-name
(testsuite-tests ',test-class
))
2253 (setf (testsuite-tests ',test-class
)
2254 (append (testsuite-tests ',test-class
) (list ',test-name
))))
2255 (defmethod lift-test ((testsuite ,test-class
) (case (eql ',test-name
)))
2257 `((setf (getf (test-data testsuite
) :options
) ',options
)))
2258 (with-test-slots ,@body
))
2259 (setf *current-test-case-name
* ',test-name
)
2260 (when (and *test-print-when-defined?
*
2261 (not (or *test-is-being-compiled?
*
2263 (format *debug-io
* "~&;Test Created: ~(~S.~S~)."
2264 ',test-class
',test-name
))
2265 *current-test-case-name
*)))
2267 (defun build-dynamics ()
2269 (dolist (putative-pair (def :dynamic-variables
))
2270 (if (atom putative-pair
)
2271 (push (list putative-pair nil
) result
)
2272 (push putative-pair result
)))
2275 (defun parse-test-body (test-body)
2276 (let ((test-name nil
)
2280 (test-number (1+ (testsuite-test-count *current-testsuite-name
*)))
2281 (name-supplied? nil
))
2282 ;; parse out any documentation
2283 (loop for form in test-body do
2284 (if (and (consp form
)
2285 (keywordp (first form
))
2286 (eq :documentation
(first form
)))
2287 (setf documentation
(second form
))
2288 (push form parsed-body
)))
2289 (setf test-body
(nreverse parsed-body
))
2290 (setf test-name
(first test-body
))
2291 (cond ((symbolp test-name
)
2293 (intern (format nil
"~A" test-name
))
2294 body
(rest test-body
)
2296 ((and (test-code->name-table
*current-testsuite-name
*)
2299 (test-code->name-table
*current-testsuite-name
*))))
2300 (setf body test-body
))
2303 (intern (format nil
"TEST-~A"
2306 (values test-name body documentation name-supplied?
)))
2308 (defun build-test-class ()
2309 ;; for now, we don't generate code from :class-def code-blocks
2310 ;; they are executed only for effect.
2311 (loop for
(nil . block
) in
*code-blocks
*
2314 (eq (operate-when block
) :class-def
)
2315 (or (not (filter block
))
2316 (funcall (filter block
)))) collect
2317 (funcall (code block
)))
2318 (unless (some (lambda (superclass)
2319 (testsuite-p superclass
))
2320 (def :superclasses
))
2321 (pushnew 'test-mixin
(def :superclasses
)))
2322 ;; build basic class and standard class
2323 `(defclass ,(def :testsuite-name
) (,@(def :superclasses
))
2325 ,@(when (def :documentation
)
2326 `((:documentation
,(def :documentation
))))
2328 :test-slot-names
',(def :slot-names
)
2329 ,@(def :default-initargs
))))
2331 (defun parse-test-slots (slot-specs)
2332 (loop for spec in slot-specs collect
2333 (let ((parsed-spec spec
))
2334 (if (member :initform parsed-spec
)
2335 (let ((pos (position :initform parsed-spec
)))
2336 (append (subseq parsed-spec
0 pos
)
2337 (subseq parsed-spec
(+ pos
2))))
2340 (defmethod testsuite-p ((classname symbol
))
2341 (let ((class (find-class classname nil
)))
2344 (typep (allocate-instance class
) 'test-mixin
)
2346 (error (c) (declare (ignore c
)) (values nil
)))))
2348 (defmethod testsuite-p ((object standard-object
))
2349 (testsuite-p (class-name (class-of object
))))
2351 (defmethod testsuite-p ((class standard-class
))
2352 (testsuite-p (class-name class
)))
2354 (defmethod testsuite-methods ((classname symbol
))
2355 (testsuite-tests classname
))
2357 (defmethod testsuite-methods ((test test-mixin
))
2358 (testsuite-methods (class-name (class-of test
))))
2360 (defmethod testsuite-methods ((test standard-class
))
2361 (testsuite-methods (class-name test
)))
2364 ;; some handy properties
2365 (defclass-property test-slots
)
2366 (defclass-property test-code-
>name-table
)
2367 (defclass-property test-name-
>code-table
)
2368 (defclass-property test-case-documentation
)
2369 (defclass-property testsuite-prototype
)
2370 (defclass-property testsuite-tests
)
2371 (defclass-property testsuite-dynamic-variables
)
2373 ;;?? issue 27: break encapsulation of code blocks
2374 (defclass-property testsuite-function-specs
)
2376 (defun empty-test-tables (test-name)
2377 (when (find-class test-name nil
)
2378 (setf (test-code->name-table test-name
)
2379 (make-hash-table :test
#'equal
)
2380 (test-name->code-table test-name
)
2381 (make-hash-table :test
#'equal
)
2382 (test-case-documentation test-name
)
2383 (make-hash-table :test
#'equal
))))
2385 (pushnew :timeout
*deftest-clauses
*)
2388 :timeout
1 :class-def
2389 (lambda () (def :timeout
))
2390 '((setf (def :timeout
) (cleanup-parsed-parameter value
)))
2392 (unless (some (lambda (super)
2393 (member (find-class 'process-test-mixin
)
2394 (superclasses super
)))
2395 (def :superclasses
))
2396 (pushnew 'process-test-mixin
(def :superclasses
)))
2397 (push (def :timeout
) (def :default-initargs
))
2398 (push :maximum-time
(def :default-initargs
))
2401 (defclass process-test-mixin
(test-mixin)
2402 ((maximum-time :initform
*test-maximum-time
*
2403 :accessor maximum-time
2404 :initarg
:maximum-time
)))
2406 (defclass test-timeout-failure
(test-failure)
2407 ((test-problem-kind :initform
"Timeout" :allocation
:class
)))
2409 (defmethod lift-test :around
((suite test-mixin
) name
)
2411 (with-profile-report ((format nil
"~a-~a"
2412 (testsuite-name suite
) name
)
2415 (call-next-method)))
2417 (defmethod do-testing :around
((testsuite process-test-mixin
) result fn
)
2418 (declare (ignore fn
))
2420 (with-timeout ((maximum-time testsuite
))
2424 (declare (ignore c
))
2425 (report-test-problem
2426 'test-timeout-failure result testsuite
(current-method testsuite
)
2427 (make-instance 'test-timeout-condition
2428 :maximum-time
(maximum-time testsuite
))))))
2431 ;; some introspection
2433 (defun liftpropos (name &key
(include-cases? nil
))
2434 (declare (ignore include-cases?
))
2436 (real-name (etypecase name
2438 (symbol (symbol-name name
)))))
2440 (lambda (suite level
)
2441 (declare (ignore level
))
2442 (let ((suite-name (symbol-name (class-name suite
))))
2443 (when (search real-name suite-name
:test
#'char-equal
)
2444 (push suite-name result
))))
2446 (sort result
#'string-lessp
)))
2448 (defun map-testsuites (fn start-at
)
2449 (let ((visited (make-hash-table)))
2450 (labels ((do-it (suite level
)
2451 (unless (gethash suite visited
)
2452 (setf (gethash suite visited
) t
)
2453 (funcall fn suite level
)
2454 (loop for subclass in
(subclasses suite
:proper? t
) do
2455 (do-it subclass
(1+ level
))))))
2456 (do-it (find-class (find-testsuite start-at
) nil
) 0))))
2458 (defun testsuites (&optional
(start-at 'test-mixin
))
2459 "Returns a list of testsuite classes. The optional parameter provides
2460 control over where in the test hierarchy the search begins."
2462 (map-testsuites (lambda (suite level
)
2463 (declare (ignore level
))
2464 (push suite result
))
2468 (defun print-tests (&key
(include-cases? t
) (start-at 'test-mixin
) (stream t
))
2469 "Prints all of the defined test classes from :start-at on down."
2471 (lambda (suite level
)
2472 (let ((indent (coerce (make-list (* level
3) :initial-element
#\Space
)
2474 (name (class-name suite
)))
2475 (format stream
"~&~a~s (~:d)"
2478 (length (testsuite-methods name
)))
2479 (when include-cases?
2480 (loop for method-name in
(testsuite-tests name
) do
2481 (format stream
"~&~a ~a" indent method-name
)))))
2484 (defun list-tests (&key
(include-cases? t
) (start-at 'test-mixin
) (stream t
))
2485 "Lists all of the defined test classes from :start-at on down."
2486 (mapc (lambda (subclass)
2487 (let ((subclass-name (class-name subclass
)))
2488 (format stream
"~&~s (~:d)"
2490 (length (testsuite-methods subclass-name
)))
2491 (when include-cases?
2492 (loop for method-name in
(testsuite-tests subclass-name
) do
2493 (format stream
"~& ~a" method-name
)))))
2494 (testsuites start-at
))
2497 (defun testsuite-test-count (testsuite)
2498 (or (and *testsuite-test-count
*
2499 (prog1 *testsuite-test-count
* (incf *testsuite-test-count
*)))
2500 (length (testsuite-methods testsuite
))))
2502 (defmethod find-testsuite ((suite symbol
))
2503 (or (testsuite-p suite
)
2504 (find-testsuite (symbol-name suite
))))
2506 (defmethod find-testsuite ((suite-name string
))
2508 (possibilities (remove-duplicates
2509 (loop for p in
(list-all-packages)
2510 when
(and (setf temp
(find-symbol suite-name p
))
2511 (find-class temp nil
)
2512 (subtypep temp
'test-mixin
)) collect
2514 (cond ((null possibilities
)
2515 (error 'testsuite-not-defined
:testsuite-name suite-name
))
2516 ((= (length possibilities
) 1)
2517 (first possibilities
))
2519 (error "There are several test suites named ~s: they are ~{~s~^, ~}"
2520 suite-name possibilities
)))))
2522 (defun test-case-p (suite-class name
)
2523 (find-method #'lift-test nil
`(,suite-class
(eql ,name
)) nil
))
2527 (find-class (find-testsuite 'test-cluster-indexing-locally
) nil
)
2528 'db.agraph.tests
::index-them
)
2531 (find-test-case (find-class (find-testsuite 'test-cluster-indexing-locally
))
2534 (defmethod find-test-case ((suite symbol
) name
)
2535 (find-test-case (find-class (find-testsuite suite
)) name
))
2537 (defmethod find-test-case ((suite test-mixin
) name
)
2538 (find-test-case (class-of suite
) name
))
2540 (defmethod find-test-case ((suite-class standard-class
) (name symbol
))
2541 (or (and (test-case-p suite-class name
) name
)
2542 (find-test-case suite-class
(symbol-name name
))))
2544 (defmethod find-test-case ((suite test-mixin
) (name string
))
2545 (find-test-case (class-of suite
) name
))
2547 (defmethod find-test-case ((suite-class standard-class
) (name string
))
2549 (possibilities (remove-duplicates
2550 (loop for p in
(list-all-packages)
2551 when
(and (setf temp
(find-symbol name p
))
2552 (test-case-p suite-class temp
)) collect
2554 (cond ((null possibilities
)
2555 (error 'test-case-not-defined
2556 :testsuite-name suite-class
:test-case-name name
))
2557 ((= (length possibilities
) 1)
2558 (first possibilities
))
2560 (error "There are several test cases of ~s named ~s: they are ~{~s~^, ~}"
2561 suite-class name possibilities
)))))
2563 (defun last-test-status ()
2564 (cond ((typep *test-result
* 'test-result
)
2565 (cond ((and (null (errors *test-result
*))
2566 (null (failures *test-result
*)))
2568 ((and (errors *test-result
*)
2569 (failures *test-result
*))
2570 :errors-and-failures
)
2571 ((errors *test-result
*)
2573 ((failures *test-result
*)
2578 (defun suite-tested-p (suite &key
(result *test-result
*))
2580 (typep *test-result
* 'test-result
)
2581 (slot-exists-p result
'suites-run
)
2582 (slot-boundp result
'suites-run
)
2583 (consp (suites-run result
))
2584 (find suite
(suites-run result
))))
2586 (defun unique-filename (pathname)
2587 (let ((date-part (date-stamp)))
2593 :name
(format nil
"~a-~a-~d"
2594 (pathname-name pathname
)
2597 (unless (probe-file name
)
2598 (return-from unique-filename name
)))
2599 (error "Unable to find unique pathname for ~a" pathname
)))
2601 (defun date-stamp (&key
(datetime (get-universal-time)) (include-time? nil
))
2602 (multiple-value-bind
2603 (second minute hour day month year day-of-the-week
)
2604 (decode-universal-time datetime
)
2605 (declare (ignore day-of-the-week
))
2606 (let ((date-part (format nil
"~d-~2,'0d-~2,'0d" year month day
))
2607 (time-part (and include-time?
2608 (list (format nil
"-~2,'0d-~2,'0d-~2,'0d"
2609 hour minute second
)))))
2610 (apply 'concatenate
'string date-part time-part
))))
2613 (date-stamp :include-time? t
)
2615 ;;?? might be "cleaner" with a macrolet (cf. lift-result)
2616 (defun lift-property (name)
2617 (when *current-test
*
2618 (getf (getf (test-data *current-test
*) :properties
) name
)))
2621 (setf (getf (getf (third (first (tests-run *test-result
*))) :properties
) :foo
)
2624 (defun (setf lift-property
) (value name
)
2625 (when *current-test
*
2626 (setf (getf (getf (test-data *current-test
*) :properties
) name
) value
)))
2630 (defmacro with-test
(&body forms
)
2631 "Execute forms in the context of the current test class."
2632 (let* ((testsuite-name *current-testsuite-name
*)
2633 (test-case (make-instance test-class
)))
2634 `(eval-when (:execute
)
2636 (setup-test ,test-case
)
2638 (with-test-slots ,@forms
))
2639 (teardown-test ,test-case
)))))
