1 ;;;-*- Mode: Lisp; Package: lift -*-
5 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
27 *test-ignore-warnings?
*
28 *test-break-on-errors?
*
31 *test-print-when-defined?
*
32 *test-evaluate-when-defined?
*
33 *test-describe-if-not-successful?
*
35 *test-print-testsuite-names
*
36 *test-print-test-case-names
*
64 ensure-random-cases-failure
65 random-instance-for-suite
79 ;;; ---------------------------------------------------------------------------
81 ;;; ---------------------------------------------------------------------------
83 (defgeneric get-class
(thing &key error?
)
84 (: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.")
85 (:method
((thing symbol
) &key error?
)
86 (find-class thing error?
))
87 (:method
((thing standard-object
) &key error?
)
88 (declare (ignore error?
))
90 (:method
((thing t
) &key error?
)
91 (declare (ignore error?
))
93 (:method
((thing class
) &key error?
)
94 (declare (ignore error?
))
97 (defun direct-subclasses (thing)
98 "Returns the immediate subclasses of thing. Thing can be a class, object or symbol naming a class."
99 (class-direct-subclasses (get-class thing
)))
101 (defun map-subclasses (class fn
&key proper?
)
102 "Applies fn to each subclass of class. If proper? is true, then
103 the class itself is not included in the mapping. Proper? defaults to nil."
104 (let ((mapped (make-hash-table :test
#'eq
)))
105 (labels ((mapped-p (class)
106 (gethash class mapped
))
108 (unless (mapped-p class
)
109 (setf (gethash class mapped
) t
)
110 (unless (and proper? root
)
112 (mapc (lambda (class)
114 (direct-subclasses class
)))))
115 (do-it (get-class class
) t
))))
117 (defun subclasses (class &key
(proper? t
))
118 "Returns all of the subclasses of the class including the class itself."
120 (map-subclasses class
(lambda (class)
125 (defun superclasses (thing &key
(proper? t
))
126 "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."
127 (let ((result (class-precedence-list (get-class thing
))))
128 (if proper?
(rest result
) result
)))
130 (defun direct-superclasses (thing)
131 "Returns the immediate superclasses of thing. Thing can be a class, object or symbol naming a class."
132 (class-direct-superclasses (get-class thing
)))
134 (declaim (inline length-1-list-p
))
135 (defun length-1-list-p (x)
136 "Is x a list of length 1?"
137 (and (consp x
) (null (cdr x
))))
139 (defmacro defclass-property
(property &optional
(default nil default-supplied?
))
140 "Create getter and setter methods for 'property' on symbol's property lists."
141 (let ((real-name (intern (format nil
"~:@(~A~)" property
) :keyword
)))
143 (defgeneric ,property
(symbol))
144 (defgeneric (setf ,property
) (value symbol
))
145 (defmethod ,property
((class-name symbol
))
146 (get class-name
,real-name
,@(when default-supplied?
(list default
))))
147 (defmethod (setf ,property
) (value (class-name symbol
))
148 (setf (get class-name
,real-name
) value
)))))
150 (defvar *automatic-slot-accessors?
* nil
)
151 (defvar *automatic-slot-initargs?
* nil
)
152 (defvar *clos-slot-options
*
153 '(:initform
:initarg
:reader
:writer
154 :accessor
:documentation
:type
157 (defun parse-brief-slot
159 (automatic-accessors?
*automatic-slot-accessors?
*)
160 (automatic-initargs?
*automatic-slot-initargs?
*)
162 (conc-separator "-"))
163 "Returns a verbose-style slot specification given a brief style, consisting of
164 a single symbol, the name of the slot, or a list of the slot name, optional
165 initform, optional symbol specifying whether there is an initarg, reader, or
166 accessor, and optional documentation string. The specification of initarg,
167 reader and accessor is done by the letters I, R and A, respectively; to specify
168 none of those, give a symbol containing none of those letters, such as the
169 symbol *. This function is used in the macro `defclass-brief,' but has been
170 broken out as a function in its own right for those writing variants on the
171 `defclass' macro. If a verbose-style slot specification is given, it is
174 If `automatic-accessors? is true, an accessor is defined, whether A is
175 specified or not _unless_ R is specified. If `automatic-initargs? is true,
176 an initarg is defined whether I is specified or not. If `conc-name' is
177 specified, the accessor name has that prepended, with conc-separator, and then
180 All other CLOS slot options are processed normally."
184 (symbol (setf slot
(list slot
)))
187 (let* ((name (pop slot
))
188 (new-slot (list name
))
191 (done-documentation? nil
)
193 (accessor-added? nil
)
194 (initargs-added? nil
))
195 (flet ((make-conc-name ()
197 (intern (format nil
"~@:(~A~A~A~)"
198 conc-name conc-separator name
))
201 (add-option (option argument
)
202 (push option new-slot
)
203 (push argument new-slot
))
205 ;; Remove duplicate options before returning the slot spec.
206 (finish-new-slot (slot)
207 ;; XXX This code is overly loopy and opaque ---L
208 (destructuring-bind (slot-name &rest options
) slot
209 (let ((opts (make-hash-table)))
210 (loop for
(key val . d
) = options then d
212 doing
(pushnew val
(gethash key opts nil
) :test
#'equal
))
213 (loop for key being each hash-key of opts using
(hash-value vals
)
214 nconc
(mapcan #'(lambda (x) (list key x
)) vals
) into spec
215 finally
(return (cons slot-name spec
)))))))
217 (do* ((items slot
(rest items
))
218 (item (first items
) (first items
))
220 (clos-item?
(member item
*clos-slot-options
*)
221 (member item
*clos-slot-options
*)))
224 (unless done-initform?
225 (setf done-initform? t
)
227 (setf process-item? nil
)
228 (unless (eq item
:UNBOUND
)
229 (push :initform new-slot
)
230 (push item new-slot
))))
233 (unless (or done-spec?
(not (symbolp item
)) clos-item?
)
235 (setf process-item? nil
)
236 ;; If you've got an A, who cares about R
237 (when (find #\A
(string item
))
238 (setf accessor-added? t
)
239 (add-option :accessor
(make-conc-name)))
240 (when (and (not accessor-added?
) (find #\R
(string item
)))
241 (setf reader-added? t
)
242 (add-option :reader
(make-conc-name)))
243 (when (find #\I
(string item
))
244 (setf initargs-added? t
)
245 (add-option :initarg
(intern (string name
)
246 (find-package :keyword
))))))
249 (unless (or done-documentation?
(not (stringp item
)))
250 (setf done-documentation? t
)
251 (push :documentation new-slot
)
259 (push (first items
) new-slot
))))
261 (when (and automatic-initargs?
(not initargs-added?
))
262 (add-option :initarg
(intern (string name
) (find-package :keyword
))))
264 (when (and automatic-accessors?
265 (and (not accessor-added?
) (not reader-added?
)))
266 (add-option :accessor
(make-conc-name)))
268 ;; finish-new-slot cleans up duplicates
269 (finish-new-slot (nreverse new-slot
)))))
271 (defun convert-clauses-into-lists (clauses-and-options clauses-to-convert
)
272 ;; This is useful (for me at least!) for writing macros
273 (let ((parsed-clauses nil
))
274 (do* ((clauses clauses-and-options
(rest clauses
))
275 (clause (first clauses
) (first clauses
)))
277 (if (and (keywordp clause
)
278 (or (null clauses-to-convert
) (member clause clauses-to-convert
))
279 (not (length-1-list-p clauses
)))
281 (setf clauses
(rest clauses
))
282 (push (list clause
(first clauses
)) parsed-clauses
))
283 (push clause parsed-clauses
)))
284 (nreverse parsed-clauses
)))
286 (defun remove-leading-quote (list)
287 "Removes the first quote from a list if one is there."
288 (if (and (consp list
) (eql (first list
) 'quote
))
292 (defun cleanup-parsed-parameter (parameter)
293 (if (length-1-list-p parameter
)
297 ;;; ---------------------------------------------------------------------------
298 ;;; global environment thingies
299 ;;; ---------------------------------------------------------------------------
301 (defparameter *make-testsuite-arguments
*
302 '(:run-setup
:test-slot-names
:equality-test
:log-file
:timeout
))
304 (defvar *current-suite-class-name
* nil
)
305 (defvar *current-case-method-name
* nil
)
307 (defvar *test-is-being-defined?
* nil
)
308 (defvar *test-is-being-compiled?
* nil
)
309 (defvar *test-is-being-loaded?
* nil
)
310 (defvar *test-is-being-executed?
* nil
)
312 (defvar *testsuite-test-count
* nil
313 "Temporary variable used to 'communicate' between deftestsuite and addtest.")
314 (defvar *lift-debug-output
* *debug-io
*
315 "Messages from LIFT will be sent to this stream. It can set to nil or
316 to an output stream. It defaults to *debug-io*.")
318 (defvar *test-break-on-errors?
* nil
)
319 (defvar *test-do-children?
* t
)
320 (defparameter *test-ignore-warnings?
* nil
321 "If true, LIFT will not cause a test to fail if a warning occurs while
322 the test is running. Note that this may interact oddly with ensure-warning.")
323 (defparameter *test-print-when-defined?
* nil
)
324 (defparameter *test-evaluate-when-defined?
* t
)
325 (defparameter *test-scratchpad
* nil
326 "A place to put things. This is set to nil before every test.")
327 (defparameter *test-notepad
* nil
328 "Another place to put things (set {ref *test-scratchpad*}.")
330 (defparameter *lift-equality-test
* 'equal
331 "The function used in ensure-same to test if two things are equal. If metatilities is loaded, then you might want to use samep.")
333 (defvar *test-describe-if-not-successful?
* nil
334 ;; Was t, but this behavior was extremely annoying since each
335 ;; time a test-restul appears in a stack backtrace it is printed
336 ;; over many unstructured lines.
337 "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.")
339 (defvar *test-print-length
* :follow-print
340 "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*`.")
341 (defvar *test-print-level
* :follow-print
342 "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.")
344 (defvar *test-print-testsuite-names
* t
345 "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*.")
347 (defvar *test-print-test-case-names
* nil
348 "If true, LIFT will print the name of each test-case before it runs. See also: *test-print-testsuite-names*.")
350 (defvar *test-result
* nil
351 "Set to the most recent test result by calls to run-test or run-tests.")
353 (defvar *test-environment
* nil
)
355 (defvar *test-metadata
* (list)
356 "A place for LIFT to put stuff.")
358 (defvar *current-test
* nil
359 "The current testsuite.")
361 (defvar *lift-dribble-pathname
* nil
362 "If bound, then test output from run-tests will be sent to this file in
363 in addition to *lift-standard-output*. It can be set to nil or to a pathname.")
365 (defvar *lift-standard-output
* *standard-output
*
366 "Output from tests will be sent to this stream. If can set to nil or
367 to an output stream. It defaults to *standard-output*.")
369 (defvar *lift-if-dribble-exists
* :append
370 "Specifies what to do to any existing file at *lift-dribble-pathname*. It
371 can be :supersede, :append, or :error.")
373 ;;; ---------------------------------------------------------------------------
374 ;;; Error messages and warnings
375 ;;; ---------------------------------------------------------------------------
377 (defparameter +lift-test-name-not-supplied-with-test-class
+
378 "if you specify a test-class, you must also specify a test-name.")
380 (defparameter +lift-test-class-not-found
+
381 "test class '~S' not found.")
383 (defparameter +lift-confused-about-arguments
+
384 "I'm confused about what you said?!")
386 (defparameter +lift-no-current-test-class
+
387 "There is no current-test-class to use as a default.")
389 (defparameter +lift-could-not-find-test
+
390 "Could not find test: ~S.~S")
392 (defparameter +run-tests-null-test-case
+
393 "There is no current testsuite (possibly because
394 none have been defined yet?). You can specify the
395 testsuite to test by evaluating (run-tests :suite <suitename>).")
397 (defparameter +lift-unable-to-parse-test-name-and-class
+
401 ;;; ---------------------------------------------------------------------------
403 ;;; ---------------------------------------------------------------------------
405 (define-condition lift-compile-error
(error)
408 :initarg
:lift-message
))
409 (:report
(lambda (c s
)
410 (format s
"Compile error: '~S'" (msg c
)))))
412 (define-condition test-class-not-defined
(lift-compile-error)
413 ((test-class-name :reader test-class-name
414 :initarg
:test-class-name
))
415 (:report
(lambda (c s
)
416 (format s
"Test class ~A not defined before it was used."
417 (test-class-name c
)))))
419 (defun build-lift-error-message (context message
&rest arguments
)
422 (apply #'format nil message arguments
)))
424 (defun signal-lift-error (context message
&rest arguments
)
425 (let ((c (make-condition
427 :lift-message
(apply #'build-lift-error-message context message arguments
))))
431 (defun report-lift-error (context message
&rest arguments
)
432 (format *debug-io
* "~&~A."
433 (apply #'build-lift-error-message context message arguments
))
436 (defun lift-report-condition (c)
437 (format *debug-io
* "~&~A." c
))
439 (define-condition test-condition
(warning)
440 ((message :initform
""
443 (:report
(lambda (c s
)
445 (format s
"~%~A" (message c
))))))
447 (define-condition ensure-failed-error
(test-condition)
448 ((assertion :initform
""
450 :initarg
:assertion
))
451 (:report
(lambda (c s
)
452 (format s
"Ensure failed: ~S ~@[(~a)~]"
453 (assertion c
) (message c
)))))
455 (define-condition ensure-null-failed-error
(ensure-failed-error)
459 (assertion :initform
""
461 :initarg
:assertion
))
462 (:report
(lambda (c s
)
463 (format s
"Ensure null failed: ~s evaluates to ~s ~@[(~a)~]"
464 (assertion c
) (value c
) (message c
)))))
466 (define-condition ensure-expected-condition
(test-condition)
467 ((expected-condition-type
469 :accessor expected-condition-type
470 :initarg
:expected-condition-type
)
473 :accessor the-condition
474 :initarg
:the-condition
))
475 (:report
(lambda (c s
)
476 (format s
"Expected ~A but got ~S"
477 (expected-condition-type c
)
478 (the-condition c
)))))
480 (define-condition ensure-not-same
(test-condition)
481 ((first-value :accessor first-value
482 :initarg
:first-value
)
483 (second-value :accessor second-value
484 :initarg
:second-value
)
487 (:report
(lambda (c s
)
488 (format s
"Ensure-same: ~S is not ~S to ~S~@[ (~a)~]"
489 (first-value c
) (test c
) (second-value c
)
492 (defmacro ensure
(predicate &key report arguments
)
493 "If ensure's `predicate` evaluates to false, then it will generate a
494 test failure. You can use the `report` and `arguments` keyword parameters
495 to customize the report generated in test results. For example:
498 :report \"I hope ~a does not = ~a\"
501 will generate a message like
503 Warning: Ensure failed: (= 23 12) (I hope 12 does not = 23)
505 (let ((gpredicate (gensym)))
506 `(let ((,gpredicate
,predicate
))
509 (let ((condition (make-condition
511 :assertion
',predicate
514 (format nil
,report
,@arguments
))))))
515 (if (find-restart 'ensure-failed
)
516 (invoke-restart 'ensure-failed condition
)
517 (warn condition
)))))))
519 (defmacro ensure-null
(predicate &key report arguments
)
520 "If ensure-null's `predicate` evaluates to true, then it will generate a
521 test failure. You can use the `report` and `arguments` keyword parameters
522 to customize the report generated in test results. See [ensure][] for more
525 `(let ((,g
,predicate
))
528 (let ((condition (make-condition 'ensure-null-failed-error
530 :assertion
',predicate
532 `(:message
(format nil
,report
,@arguments
))))))
533 (if (find-restart 'ensure-failed
)
534 (invoke-restart 'ensure-failed condition
)
535 (warn condition
)))))))
537 (defmacro ensure-condition
(condition &body body
)
538 "This macro is used to make sure that body really does produce condition."
539 (setf condition
(remove-leading-quote condition
))
540 (destructuring-bind (condition &key report arguments
)
541 (if (consp condition
) condition
(list condition
))
548 (declare (ignore cond
)) (setf ,g t
))
551 (let ((c (make-condition
552 'ensure-expected-condition
553 :expected-condition-type
',condition
556 `(:message
(format nil
,report
,arguments
))))))
557 (if (find-restart 'ensure-failed
)
558 (invoke-restart 'ensure-failed c
)
561 (if (find-restart 'ensure-failed
)
565 'ensure-expected-condition
566 :expected-condition-type
',condition
569 `(:message
(format nil
,report
,arguments
)))))
570 (warn "Ensure-condition didn't get the condition it expected."))))))))
572 (defmacro ensure-warning
(&body body
)
573 "Ensure-warning evaluates its body. If the body does *not* signal a
574 warning, then ensure-warning will generate a test failure."
575 `(ensure-condition warning
,@body
))
577 (defmacro ensure-error
(&body body
)
578 "Ensure-error evaluates its body. If the body does *not* signal an
579 error, then ensure-error will generate a test failure."
580 `(ensure-condition error
,@body
))
582 (defmacro ensure-same
583 (form values
&key
(test nil test-specified-p
)
584 (report nil
) (arguments nil
))
585 "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"
586 (setf test
(remove-leading-quote test
))
587 (when (and (consp test
)
588 (eq (first test
) 'function
))
589 (setf test
(second test
)))
590 (let ((block (gensym)))
592 (loop for value in
(multiple-value-list ,form
)
593 for other-value in
(multiple-value-list ,values
) do
594 (unless (funcall ,(if test-specified-p
(list 'quote test
) '*lift-equality-test
*)
596 (maybe-raise-not-same-condition
598 ,(if test-specified-p
(list 'quote test
) '*lift-equality-test
*)
600 (return-from ,block nil
)))
603 (defmacro ensure-different
604 (form values
&key
(test nil test-specified-p
)
605 (report nil
) (arguments nil
))
606 "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"
607 ;; FIXME -- share code with ensure-same
608 (setf test
(remove-leading-quote test
))
609 (when (and (consp test
)
610 (eq (first test
) 'function
))
611 (setf test
(second test
)))
613 (loop for value in
(multiple-value-list ,form
)
614 for other-value in
(multiple-value-list ,values
) do
615 ;; WHEN instead of UNLESS
616 (when (funcall ,(if test-specified-p
618 '*lift-equality-test
*)
620 (maybe-raise-not-same-condition
622 ,(if test-specified-p
624 '*lift-equality-test
*) ,report
,@arguments
)))
627 (defun maybe-raise-not-same-condition (value-1 value-2 test
628 report
&rest arguments
)
629 (let ((condition (make-condition 'ensure-not-same
631 :second-value value-2
633 :message
(when report
635 report arguments
)))))
636 (if (find-restart 'ensure-failed
)
637 (invoke-restart 'ensure-failed condition
)
640 (define-condition ensure-cases-failure
(test-condition)
641 ((total :initarg
:total
:initform
0)
642 (problems :initarg
:problems
:initform nil
))
643 (:report
(lambda (condition stream
)
644 (format stream
"Ensure-cases: ~d out of ~d cases failed. Failing cases are: ~{~% ~{~s (~a)~}~^, ~}"
645 (length (slot-value condition
'problems
))
646 (slot-value condition
'total
)
647 (slot-value condition
'problems
)))))
649 (defmacro ensure-cases
((&rest vars
) (&rest cases
) &body body
)
650 (let ((case (gensym))
653 `(let ((,problems nil
) (,total
0))
654 (loop for
,case in
,cases do
656 (destructuring-bind ,vars
,case
659 (ensure-failed (cond)
660 (push (list ,case cond
) ,problems
)))))
662 (let ((condition (make-condition
663 'ensure-cases-failure
665 :problems
,problems
)))
666 (if (find-restart 'ensure-failed
)
667 (invoke-restart 'ensure-failed condition
)
668 (warn condition
)))))))
671 ;;; ---------------------------------------------------------------------------
673 ;;; ---------------------------------------------------------------------------
675 (defclass test-mixin
()
676 ((name :initform nil
:initarg
:name
:accessor name
:reader testsuite-name
)
677 (run-setup :reader run-setup
:initarg
:run-setup
)
678 (done-setup?
:initform nil
:reader done-setup?
)
679 (done-dynamics?
:initform nil
:reader done-dynamics?
)
680 (prototypes :initform
(list (list)) :accessor prototypes
)
681 (prototypes-initialized?
:initform nil
:reader prototypes-initialized?
)
682 (current-values :initform nil
:accessor current-values
)
683 (test-slot-names :initform nil
:initarg
:test-slot-names
684 :reader test-slot-names
)
685 (current-step :initform
:created
:accessor current-step
)
686 (current-method :initform nil
:accessor current-method
)
687 (save-equality-test :initform nil
:reader save-equality-test
)
688 (equality-test :initform
'equal
:initarg
:equality-test
689 :reader equality-test
)
690 (log-file :initform nil
:initarg
:log-file
:reader log-file
)
691 (test-data :initform nil
:accessor test-data
)
692 (expected-failure-p :initform nil
:initarg
:expected-failure-p
693 :reader expected-failure-p
)
694 (expected-error-p :initform nil
:initarg
:expected-error-p
695 :reader expected-error-p
)
696 (expected-problem-p :initform nil
:initarg
:expected-problem-p
697 :reader expected-problem-p
))
698 (:documentation
"A test suite")
700 :run-setup
:once-per-test-case
))
702 (defclass test-result
()
703 ((results-for :initform nil
704 :initarg
:results-for
705 :accessor results-for
)
706 (tests-run :initform nil
:accessor tests-run
)
707 (suites-run :initform nil
:accessor suites-run
)
708 (failures :initform nil
:accessor failures
)
709 (expected-failures :initform nil
:accessor expected-failures
)
710 (errors :initform nil
:accessor errors
)
711 (expected-errors :initform nil
:accessor expected-errors
)
712 (test-mode :initform
:single
:initarg
:test-mode
:accessor test-mode
)
713 (test-interactive?
:initform nil
714 :initarg
:test-interactive?
:accessor test-interactive?
)
715 (real-start-time :initarg
:real-start-time
:reader real-start-time
)
716 (start-time :accessor start-time
:initform nil
)
717 (end-time :accessor end-time
)
718 (real-end-time :accessor real-end-time
)
719 (real-start-time-universal
720 :initarg
:real-start-time-universal
:reader real-start-time-universal
)
721 (start-time-universal :accessor start-time-universal
:initform nil
)
722 (end-time-universal :accessor end-time-universal
)
723 (real-end-time-universal :accessor real-end-time-universal
)
724 (properties :initform nil
:accessor test-result-properties
))
726 :test-interactive?
*test-is-being-defined?
*
727 :real-start-time
(get-internal-real-time)
728 :real-start-time-universal
(get-universal-time)))
730 (defun test-result-property (result property
)
731 (getf (test-result-properties result
) property
))
733 (defun (setf test-result-property
) (value result property
)
734 (setf (getf (test-result-properties result
) property
) value
))
736 (defun print-lift-message (message &rest args
)
737 (apply #'format
*lift-debug-output
* message args
)
738 (force-output *lift-debug-output
*))
740 (defgeneric testsuite-setup
(testsuite result
)
741 (:documentation
"Setup at the testsuite-level")
742 (:method
((testsuite test-mixin
) (result test-result
))
744 (:method
:before
((testsuite test-mixin
) (result test-result
))
745 (when (and *test-print-testsuite-names
*
746 (eq (test-mode result
) :multiple
))
747 (print-lift-message "~&Start: ~a" (type-of testsuite
)))
748 (push (type-of testsuite
) (suites-run result
))
749 (setf (current-step testsuite
) :testsuite-setup
)))
751 (defgeneric testsuite-run
(testsuite result
)
752 (:documentation
"Run the cases in this suite and it's children."))
754 (defgeneric testsuite-teardown
(testsuite result
)
755 (:documentation
"Cleanup at the testsuite level.")
756 (:method
((testsuite test-mixin
) (result test-result
))
759 (:method
:after
((testsuite test-mixin
) (result test-result
))
760 (setf (current-step testsuite
) :testsuite-teardown
761 (real-end-time result
) (get-internal-real-time)
762 (real-end-time-universal result
) (get-universal-time))))
764 (defgeneric more-prototypes-p
(testsuite)
765 (:documentation
"Returns true if another prototype set exists for the case."))
767 (defgeneric initialize-prototypes
(testsuite)
768 (:documentation
"Creates lists of all prototype sets."))
770 (defgeneric next-prototype
(testsuite)
771 (:documentation
"Ensures that the test environment has the values of the next prototype set."))
773 (defgeneric make-single-prototype
(testsuite))
775 (defgeneric setup-test
(testsuite)
776 (:documentation
"Setup for a test-case. By default it does nothing."))
778 (defgeneric teardown-test
(testsuite)
779 (:documentation
"Tear-down a test-case. By default it does nothing.")
780 (:method-combination progn
:most-specific-first
))
782 (defgeneric testsuite-methods
(testsuite)
783 (:documentation
"Returns a list of the test methods defined for test. I.e.,
784 the methods that should be run to do the tests for this test."))
786 (defgeneric lift-test
(suite name
)
789 (defgeneric do-testing
(testsuite result fn
)
792 (defgeneric end-test
(result case method-name
)
795 (defgeneric initialize-test
(test)
798 (defgeneric run-test-internal
(suite name result
)
801 (defgeneric run-tests-internal
(suite &key result
)
804 (defgeneric start-test
(result case method-name
)
807 (defgeneric test-report-code
(testsuite method
)
810 (defgeneric testsuite-p
(thing)
811 (: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."))
813 (defgeneric testsuite-name-
>gf
(case name
)
816 (defgeneric testsuite-name-
>method
(class name
)
819 (defmethod setup-test :before
((test test-mixin
))
820 (setf *test-scratchpad
* nil
821 (current-step test
) :test-setup
))
823 (defmethod setup-test ((test test-mixin
))
826 (defmethod teardown-test progn
((test test-mixin
))
829 (defmethod teardown-test :around
((test test-mixin
))
830 (setf (current-step test
) :test-teardown
)
833 (defmethod initialize-test ((test test-mixin
))
836 (defmethod initialize-test :before
((test test-mixin
))
838 (initialize-prototypes test
)
839 (next-prototype test
))
841 (defmethod initialize-instance :after
((testsuite test-mixin
) &key
)
842 (when (null (testsuite-name testsuite
))
843 (setf (slot-value testsuite
'name
)
844 (symbol-name (type-of testsuite
)))))
846 (defmethod print-object ((tc test-mixin
) stream
)
847 (print-unreadable-object (tc stream
:identity t
:type t
)
848 (format stream
"~a" (testsuite-name tc
))))
850 ;;; ---------------------------------------------------------------------------
852 ;;; ---------------------------------------------------------------------------
854 (defvar *current-definition
* nil
855 "An associative-container which saves interesting information about
856 the thing being defined.")
858 (defun initialize-current-definition ()
859 (setf *current-definition
* nil
))
861 (defun set-definition (name value
)
862 (let ((current (assoc name
*current-definition
*)))
864 (setf (cdr current
) value
)
865 (push (cons name value
) *current-definition
*)))
869 (defun def (name &optional
(definition *current-definition
*))
870 (when definition
(cdr (assoc name definition
))))
872 (defun (setf def
) (value name
)
873 (set-definition name value
))
875 (defvar *code-blocks
* nil
)
877 (defstruct (code-block (:type list
) (:conc-name nil
))
878 block-name
(priority 0) filter code operate-when
)
880 (defgeneric block-handler
(name value
)
882 (:method
((name t
) (value t
))
883 (error "Unknown clause: ~A" name
)))
885 (defun add-code-block (name priority operate-when filter handler code
)
886 (let ((current (assoc name
*code-blocks
*))
887 (value (make-code-block
888 :operate-when operate-when
894 (setf (cdr current
) value
)
895 (push (cons name value
) *code-blocks
*))
897 `(defmethod block-handler ((name (eql ',name
)) value
)
898 (declare (ignorable value
))
900 (setf *code-blocks
* (sort *code-blocks
* #'<
901 :key
(lambda (name.cb
)
902 (priority (cdr name.cb
))))))
904 (defmacro with-test-slots
(&body body
)
905 `(symbol-macrolet ((lift-result (getf (test-data *current-test
*) :result
)))
907 ,(mapcar #'(lambda (local)
908 `(,local
(test-environment-value ',local
)))
911 ,(mapcar (lambda (spec)
912 (destructuring-bind (name arglist
) spec
915 *current-test
* ',',name
,,@arglist
))))
916 (def :function-specs
))
919 (defvar *deftest-clauses
*
920 '(:setup
:teardown
:test
:documentation
:tests
:export-p
:export-slots
921 :run-setup
:dynamic-variables
:equality-test
:categories
:function
))
923 (defmacro deftest
(testsuite-name superclasses slots
&rest
925 "The `deftest` form is obsolete, see [deftestsuite][]."
927 (warn "Deftest is obsolete, use deftestsuite instead.")
928 `(deftestsuite ,testsuite-name
,superclasses
,slots
,@clauses-and-options
))
930 (setf *code-blocks
* nil
)
934 (lambda () (or (def :setup
) (def :direct-slot-names
)))
935 '((setf (def :setup
) (cleanup-parsed-parameter value
)))
936 'build-setup-test-method
)
939 :teardown
100 :methods
940 (lambda () (or (def :teardown
) (def :direct-slot-names
)))
941 '((setf (def :teardown
) (cleanup-parsed-parameter value
)))
942 'build-test-teardown-method
)
946 (lambda () (def :functions
))
947 '((push value
(def :functions
)))
948 'build-test-local-functions
)
951 :documentation
0 :class-def
953 '((setf (def :documentation
) (first value
)))
957 :export-p
0 :class-def
959 '((setf (def :export-p
) (first value
)))
963 :export-slots
0 :class-def
965 '((setf (def :export-slots
) (first value
)))
969 :run-setup
0 :class-def
971 '((push (first value
) (def :default-initargs
))
972 (push :run-setup
(def :default-initargs
))
973 (setf (def :run-setup
) (first value
)))
977 :equality-test
0 :class-def
979 '((push (first value
) (def :default-initargs
))
980 (push :equality-test
(def :default-initargs
)))
984 :log-file
0 :class-def
986 '((push (first value
) (def :default-initargs
))
987 (push :log-file
(def :default-initargs
)))
991 :dynamic-variables
0 :class-def
993 '((setf (def :direct-dynamic-variables
) value
))
997 :categories
0 :class-def
999 '((push value
(def :categories
)))
1002 (defmacro deftestsuite
(testsuite-name superclasses slots
&rest
1003 clauses-and-options
)
1005 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.
1007 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.
1009 Slots are specified as in defclass with the following additions:
1011 * 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)`.
1012 * 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
1014 (deftestsuite my-test ()
1017 then `my-slot` will be initialized to 23 during test setup.
1019 Test options are one of :setup, :teardown, :test, :tests, :documentation, :export-p, :dynamic-variables, :export-slots, :function, :categories, :run-setup, or :equality-test.
1021 * :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.
1023 * :documentation - a string specifying any documentation for the test. Should only be specified once.
1025 * :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.
1027 * :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.
1029 * :export-p - If true, the testsuite name will be exported from the current package. Should only be specified once.
1031 * :export-slots - if true, any slots specified in the test suite will be exported from the current package. Should only be specified once.
1033 * :function - creates a locally accessible function for this test suite. May be specified multiple times.
1035 * :run-setup - specify when to run the setup code for this test suite. Allowed values are
1037 * :once-per-test-case or t (the default)
1042 :run-setup is handy when a testsuite has a time consuming setup phase that you do not want to repeat for every test.
1044 * :setup - a list of forms to be evaluated before each test case is run. Should only be specified once.
1046 * :teardown - a list of forms to be evaluated after each test case is run. Should only be specified once.
1048 * :test - Define a single test case. Can be specified multiple times.
1050 * :tests - Define multiple test cases for this test suite. Can be specified multiple times.
1055 (let ((test-list nil
)
1058 ;; convert any clause like :setup foo into (:setup foo)
1059 (setf clauses-and-options
1060 (convert-clauses-into-lists clauses-and-options
*deftest-clauses
*))
1061 (initialize-current-definition)
1062 (setf (def :testsuite-name
) testsuite-name
)
1063 (setf (def :superclasses
) (mapcar #'find-testsuite superclasses
))
1064 (setf (def :deftestsuite
) t
)
1065 ;; parse clauses into defs
1066 (loop for clause in clauses-and-options do
1068 (symbol (pushnew clause options
))
1069 (cons (destructuring-bind (kind &rest spec
) clause
1071 (:test
(push (first spec
) test-list
))
1073 (loop for test in spec do
1074 (push test test-list
)))
1075 (t (block-handler kind spec
)))))
1076 (t (error "When parsing ~S" clause
))))
1077 (let ((slot-names nil
) (slot-specs nil
))
1078 (loop for slot in
(if (listp slots
) slots
(list slots
)) do
1079 (push (if (consp slot
) (first slot
) slot
) slot-names
)
1080 (push (parse-brief-slot slot nil nil nil nil
) slot-specs
))
1081 (setf (def :slot-specs
) (nreverse slot-specs
)
1082 (def :direct-slot-names
) (nreverse slot-names
)
1083 (def :slots-parsed
) t
))
1084 ;;?? issue 27: breaks 'encapsulation' of code-block mechanism
1085 (setf (def :function-specs
)
1086 (loop for spec in
(def :functions
) collect
1087 (destructuring-bind (name arglist
&body body
) (first spec
)
1088 (declare (ignore body
))
1089 `(,name
,arglist
))))
1091 (empty-test-tables testsuite-name
)
1092 (compute-superclass-inheritence)
1094 (setf *testsuite-test-count
* 0)
1095 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
1096 (eval-when (:compile-toplevel
)
1097 (push ',return
*test-is-being-compiled?
*))
1098 (eval-when (:load-toplevel
)
1099 (push ',return
*test-is-being-loaded?
*))
1100 (eval-when (:execute
)
1101 (push ',return
*test-is-being-executed?
*))
1102 ;; remove previous methods (do this _before_ we define the class)
1103 (remove-previous-definitions ',(def :testsuite-name
))
1106 (let ((*test-is-being-defined?
* t
))
1107 (setf *current-case-method-name
* nil
)
1108 (setf *current-suite-class-name
* ',(def :testsuite-name
)
1109 (test-slots ',(def :testsuite-name
))
1111 (testsuite-dynamic-variables ',(def :testsuite-name
))
1112 ',(def :dynamic-variables
)
1113 ;;?? issue 27: breaks 'encapsulation' of code-block mechanism
1114 (testsuite-function-specs ',(def :testsuite-name
))
1115 ',(def :function-specs
))
1116 ,@(when (def :export-p
)
1117 `((export '(,(def :testsuite-name
)))))
1118 ,@(when (def :export-slots?
)
1119 `((export ',(def :direct-slot-names
))))
1120 ;; make a place to save test-case information
1121 (empty-test-tables ',(def :testsuite-name
))
1124 ,@(build-initialize-test-method)
1125 ,@(loop for
(nil . block
) in
*code-blocks
*
1128 (eq (operate-when block
) :methods
)
1129 (or (not (filter block
))
1130 (funcall (filter block
)))) collect
1131 (funcall (code block
)))
1132 ,@(when (def :dynamic-variables
)
1133 `((defmethod do-testing :around
1134 ((suite ,(def :testsuite-name
)) result fn
)
1135 (declare (ignore result fn
))
1136 (cond ((done-dynamics? suite
)
1139 (setf (slot-value suite
'done-dynamics?
) t
)
1140 (let* (,@(build-dynamics))
1141 (call-next-method)))))))
1144 `((let ((*test-evaluate-when-defined?
* nil
))
1145 ,@(loop for test in
(nreverse test-list
) collect
1146 `(addtest (,(def :testsuite-name
))
1148 (setf *testsuite-test-count
* nil
))))
1149 ,(if *test-evaluate-when-defined?
*
1150 `(unless (or *test-is-being-compiled?
*
1151 *test-is-being-loaded?
*)
1152 (let ((*test-break-on-errors?
* *test-break-on-errors?
*))
1153 (run-tests :suite
',testsuite-name
)))
1154 `(find-class ',testsuite-name
)))
1156 (setf *test-is-being-compiled?
*
1157 (remove ',return
*test-is-being-compiled?
*))
1158 (setf *test-is-being-loaded?
*
1159 (remove ',return
*test-is-being-loaded?
*))
1160 (setf *test-is-being-executed?
*
1161 (remove ',return
*test-is-being-executed?
*)))))))
1163 (defun compute-superclass-inheritence ()
1164 ;;?? issue 27: break encapsulation of code blocks
1165 ;;?? we assume that we won't have too deep a hierarchy or too many
1166 ;; dv's or functions so that having lots of duplicate names is OK
1168 (dynamic-variables nil
)
1169 (function-specs nil
))
1170 (dolist (super (def :superclasses
))
1171 (cond ((find-testsuite super
)
1172 (setf slots
(append slots
(test-slots super
))
1174 (append dynamic-variables
1175 (testsuite-dynamic-variables super
))
1177 (append function-specs
1178 (testsuite-function-specs super
))))
1180 (error 'test-class-not-defined
:test-class-name super
))))
1181 (setf (def :slot-names
)
1182 (remove-duplicates (append (def :direct-slot-names
) slots
))
1183 (def :dynamic-variables
)
1185 (append (def :direct-dynamic-variables
) dynamic-variables
))
1186 (def :function-specs
)
1188 (append (def :function-specs
) function-specs
)))
1189 (setf (def :superclasses
)
1190 (loop for class in
(def :superclasses
)
1191 unless
(some (lambda (oter)
1192 (and (not (eq class oter
))
1193 (member class
(superclasses oter
))))
1194 (def :superclasses
)) collect
1197 (defmacro addtest
(name &body test
)
1198 "Adds a single new test-case to the most recently defined testsuite."
1205 (looks-like-suite-name (looks-like-suite-name-p name
))
1206 (looks-like-code (looks-like-code-p name
)))
1207 (cond ((and looks-like-suite-name looks-like-code
)
1208 (error "Can't disambiguate suite name from possible code."))
1209 (looks-like-suite-name
1211 (setf (def :testsuite-name
) (first name
)
1213 name nil body test
))
1215 ;; the 'name' is really part of the test...
1216 (setf body
(cons name test
))))
1217 (unless (def :testsuite-name
)
1218 (when *current-suite-class-name
*
1219 (setf (def :testsuite-name
) *current-suite-class-name
*)))
1220 (unless (def :testsuite-name
)
1221 (signal-lift-error 'add-test
+lift-no-current-test-class
+))
1222 (unless (or (def :deftestsuite
)
1223 (find-testsuite (def :testsuite-name
)))
1224 (signal-lift-error 'add-test
+lift-test-class-not-found
+
1225 (def :testsuite-name
)))
1226 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
1227 (eval-when (:compile-toplevel
)
1228 (push ',return
*test-is-being-compiled?
*))
1229 (eval-when (:load-toplevel
)
1230 (push ',return
*test-is-being-loaded?
*))
1231 (eval-when (:execute
)
1232 (push ',return
*test-is-being-executed?
*))
1234 (let ((*test-is-being-defined?
* t
))
1235 ,(build-test-test-method (def :testsuite-name
) body options
)
1236 (setf *current-suite-class-name
* ',(def :testsuite-name
))
1237 (if *test-evaluate-when-defined?
*
1238 (unless (or *test-is-being-compiled?
*
1239 *test-is-being-loaded?
*)
1240 (let ((*test-break-on-errors?
* (testing-interactively-p)))
1244 (setf *test-is-being-compiled?
*
1245 (remove ',return
*test-is-being-compiled?
*)
1246 *test-is-being-loaded?
*
1247 (remove ',return
*test-is-being-loaded?
*)
1248 *test-is-being-executed?
*
1249 (remove ',return
*test-is-being-executed?
*))))))
1251 (defun looks-like-suite-name-p (form)
1254 (find-testsuite (first form
))
1255 (property-list-p (rest form
))))
1257 (defun property-list-p (form)
1262 for want-keyword?
= t then
(not want-keyword?
) do
1263 (when (and want-keyword?
(not (keywordp x
)))
1264 (return-from check-it nil
))
1265 (setf even?
(not even?
)))
1266 (return-from check-it even?
)))))
1269 (property-list-p '(:a
:b
))
1270 (property-list-p '(:a
2 :b
3 :c
5 :d
8))
1271 (property-list-p nil
)
1274 (property-list-p '(3))
1275 (property-list-p '(3 :a
))
1276 (property-list-p '(:a
3 :b
))
1279 (defun looks-like-code-p (name)
1280 (declare (ignore name
))
1284 (defun remove-test (&key
(name *current-case-method-name
*)
1285 (suite *current-suite-class-name
*))
1286 (assert suite nil
"Test suite could not be determined.")
1287 (assert name nil
"Test name could not be determined.")
1288 (setf (testsuite-tests suite
)
1289 (remove name
(testsuite-tests suite
))))
1291 (defun run-test (&rest args
1292 &key
(name *current-case-method-name
*)
1293 (suite *current-suite-class-name
*)
1294 (break-on-errors?
*test-break-on-errors?
*)
1295 (do-children?
*test-do-children?
*)
1297 (assert suite nil
"Test suite could not be determined.")
1298 (assert name nil
"Test name could not be determined.")
1299 (let* ((*test-break-on-errors?
* break-on-errors?
)
1300 (*test-do-children?
* do-children?
)
1301 (*current-test
* (make-testsuite suite args
)))
1303 (setf result
(make-test-result suite
:single
)))
1304 (setf *current-case-method-name
* (find-test-case suite name
)
1305 *current-suite-class-name
* suite
)
1306 (do-testing *current-test
* result
1309 *current-test
* *current-case-method-name
* result
)))))
1311 (defun make-testsuite (suite args
)
1312 (let ((make-instance-args nil
))
1313 (loop for keyword in
*make-testsuite-arguments
* do
1314 (when (member keyword args
)
1315 (push keyword make-instance-args
)
1316 (push (getf args keyword
) make-instance-args
)))
1317 (apply #'make-instance
(find-testsuite suite
) make-instance-args
)))
1319 (defmethod do-testing ((testsuite test-mixin
) result fn
)
1322 (testsuite-setup testsuite result
)
1323 (let ((*lift-equality-test
* (equality-test testsuite
)))
1325 ((not (more-prototypes-p testsuite
)) result
)
1326 (initialize-test testsuite
)
1329 (testsuite-teardown testsuite result
))
1332 (defmethod run-tests-internal ((suite symbol
) &rest args
&key
&allow-other-keys
)
1333 (let ((*current-test
* (make-testsuite suite args
)))
1334 (apply #'run-tests-internal
1338 (defmethod run-tests-internal
1339 ((case test-mixin
) &key
1340 (result (make-test-result (class-of case
) :multiple
))
1341 (do-children?
*test-do-children?
*))
1342 (let ((*test-do-children?
* do-children?
))
1343 (do-testing case result
1345 (testsuite-run case result
)))
1346 (setf *test-result
* result
)))
1349 (defmacro with-test
(&body forms
)
1350 "Execute forms in the context of the current test class."
1351 (let* ((test-class-name *current-suite-class-name
*)
1352 (test-case (make-instance test-class
)))
1353 `(eval-when (:execute
)
1355 (setup-test ,test-case
)
1357 (with-test-slots ,@forms
))
1358 (teardown-test ,test-case
)))))
1360 (defun map-testsuites (fn start-at
)
1361 (let ((visited (make-hash-table)))
1362 (labels ((do-it (suite level
)
1363 (unless (gethash suite visited
)
1364 (setf (gethash suite visited
) t
)
1365 (funcall fn suite level
)
1366 (loop for subclass in
(subclasses suite
:proper? t
) do
1367 (do-it subclass
(1+ level
))))))
1368 (do-it (find-class (find-testsuite start-at
) nil
) 0))))
1370 (defun testsuites (&optional
(start-at 'test-mixin
))
1371 "Returns a list of testsuite classes. The optional parameter provides
1372 control over where in the test hierarchy the search begins."
1374 (map-testsuites (lambda (suite level
)
1375 (declare (ignore level
))
1376 (push suite result
))
1380 (defun print-tests (&key
(include-cases? t
) (start-at 'test-mixin
) (stream t
))
1381 "Prints all of the defined test classes from :start-at on down."
1383 (lambda (suite level
)
1384 (let ((indent (coerce (make-list (* level
3) :initial-element
#\Space
)
1386 (name (class-name suite
)))
1387 (format stream
"~&~a~s (~:d)"
1390 (length (testsuite-methods name
)))
1391 (when include-cases?
1392 (loop for method-name in
(testsuite-tests name
) do
1393 (format stream
"~&~a ~a" indent method-name
)))))
1396 (defun list-tests (&key
(include-cases? t
) (start-at 'test-mixin
) (stream t
))
1397 "Lists all of the defined test classes from :start-at on down."
1398 (mapc (lambda (subclass-name)
1399 (format stream
"~&~s (~:d)"
1401 (length (testsuite-methods subclass-name
)))
1402 (when include-cases?
1403 (loop for method-name in
(testsuite-tests subclass-name
) do
1404 (format stream
"~& ~a" method-name
))))
1405 (testsuites start-at
))
1408 (defun testsuite-test-count (testsuite)
1409 (or (and *testsuite-test-count
*
1410 (prog1 *testsuite-test-count
* (incf *testsuite-test-count
*)))
1411 (length (testsuite-methods testsuite
))))
1413 (defun run-tests (&rest args
&key
1415 (break-on-errors?
*test-break-on-errors?
*)
1417 (dribble *lift-dribble-pathname
*)
1418 (result (make-test-result (or suite config
) :multiple
))
1421 "Run all of the tests in a suite. Arguments are :suite, :result, ~
1422 :do-children? and :break-on-errors?"
1424 (remf args
:break-on-errors?
)
1425 (remf args
:run-setup
)
1426 (remf args
:dribble
)
1427 (cond ((and suite config
)
1428 (error "Specify either configuration file or test suite
1431 (run-tests-from-file config
))
1432 ((or suite
(setf suite
*current-suite-class-name
*))
1433 (let* ((*test-break-on-errors?
* break-on-errors?
)
1438 :if-does-not-exist
:create
1439 :if-exists
*lift-if-dribble-exists
*)))
1440 (*standard-output
* (maybe-add-dribble
1441 *lift-standard-output
* dribble-stream
))
1442 (*error-output
* (maybe-add-dribble
1443 *error-output
* dribble-stream
))
1444 (*debug-io
* (maybe-add-dribble
1445 *debug-io
* dribble-stream
)))
1447 (dolist (name (if (consp suite
) suite
(list suite
)))
1448 (setf *current-suite-class-name
* name
)
1449 (apply #'run-tests-internal name
:result result args
))
1451 (when dribble-stream
1452 (close dribble-stream
)))
1454 (setf (tests-run result
) (reverse (tests-run result
)))
1457 (error "There is not a current test suite and neither suite
1458 nor configuration file options were specified."))))
1460 (defun maybe-add-dribble (stream dribble-stream
)
1462 (values (make-broadcast-stream stream dribble-stream
) t
)
1463 (values stream nil
)))
1465 (defmethod testsuite-run ((case test-mixin
) (result test-result
))
1466 (unless (start-time result
)
1467 (setf (start-time result
) (get-internal-real-time)
1468 (start-time-universal result
) (get-universal-time)))
1470 (let ((methods (testsuite-methods case
)))
1471 (loop for method in methods do
1472 (run-test-internal case method result
))
1473 (when *test-do-children?
*
1474 (loop for subclass in
(direct-subclasses (class-of case
))
1475 when
(and (testsuite-p subclass
)
1476 (not (member (class-name subclass
)
1477 (suites-run result
)))) do
1478 (run-tests-internal (class-name subclass
)
1480 (setf (end-time result
) (get-universal-time))))
1482 (defmethod more-prototypes-p ((testsuite test-mixin
))
1483 (not (null (prototypes testsuite
))))
1485 (defmethod initialize-prototypes ((testsuite test-mixin
))
1486 (setf (prototypes testsuite
)
1487 (list (make-single-prototype testsuite
))))
1489 (defmethod make-single-prototype ((testsuite test-mixin
))
1492 (defmethod initialize-prototypes :around
((suite test-mixin
))
1493 (unless (prototypes-initialized? suite
)
1494 (setf (slot-value suite
'prototypes-initialized?
) t
)
1495 (call-next-method)))
1497 (defmethod next-prototype ((testsuite test-mixin
))
1498 (setf (current-values testsuite
) (first (prototypes testsuite
))
1499 (prototypes testsuite
) (rest (prototypes testsuite
)))
1500 (dolist (key.value
(current-values testsuite
))
1501 (setf (test-environment-value (car key.value
)) (cdr key.value
))))
1503 (defmethod run-test-internal ((suite test-mixin
) (name symbol
) result
)
1504 (when (and *test-print-test-case-names
*
1505 (eq (test-mode result
) :multiple
))
1506 (print-lift-message "~& run: ~a" name
))
1507 (let ((problem nil
))
1509 (declare (ignorable problem
))
1513 (handler-bind ((warning #'muffle-warning
)
1514 ; ignore warnings...
1518 (report-test-problem
1519 'test-error result suite name cond
1520 :backtrace
(get-backtrace cond
)))
1521 (if *test-break-on-errors?
*
1522 (invoke-debugger cond
)
1525 ;; FIXME - too much! should we catch serious-conditions?
1528 (report-test-problem
1529 'test-error result suite name cond
1530 :backtrace
(get-backtrace cond
))))))
1532 (current-method suite
) name
)
1533 (start-test result suite name
)
1537 (declare (ignorable result
))
1538 (setf (current-step suite
) :testing
1541 (getf (test-data suite
) :seconds
)
1542 (getf (test-data suite
) :conses
)
1543 (lift-test suite name
)))
1544 (check-for-surprises result suite name
))
1545 (teardown-test suite
)
1546 (end-test result suite name
)))
1547 (ensure-failed (cond)
1549 (report-test-problem
1550 'test-failure result suite name cond
)))
1551 (retry-test () :report
"Retry the test."
1554 (setf (third (first (tests-run result
))) (test-data suite
))
1555 (setf *test-result
* result
))
1557 (define-condition unexpected-success-failure
(test-condition)
1558 ((expected :reader expected
:initarg
:expected
)
1559 (expected-more :reader expected-more
:initarg
:expected-more
))
1560 (:report
(lambda (c s
)
1561 (format s
"Test succeeded but we expected ~s (~s)"
1563 (expected-more c
)))))
1565 (defun check-for-surprises (results testsuite name
)
1566 (declare (ignore results name
))
1567 (let* ((options (getf (test-data testsuite
) :options
))
1568 (expected-failure-p (second (member :expected-failure options
)))
1569 (expected-error-p (second (member :expected-error options
)))
1570 (expected-problem-p (second (member :expected-problem options
)))
1574 (setf (slot-value testsuite
'expected-failure-p
) expected-failure-p
))
1576 (setf (slot-value testsuite
'expected-error-p
) expected-error-p
))
1578 (setf (slot-value testsuite
'expected-problem-p
) expected-problem-p
)))
1580 ((expected-failure-p testsuite
)
1582 (make-condition 'unexpected-success-failure
1584 :expected-more
(expected-failure-p testsuite
))))
1585 ((expected-error-p testsuite
)
1587 (make-condition 'unexpected-success-failure
1589 :expected-more
(expected-error-p testsuite
))))
1590 ((expected-problem-p testsuite
)
1592 (make-condition 'unexpected-success-failure
1594 :expected-more
(expected-problem-p testsuite
)))))
1596 (if (find-restart 'ensure-failed
)
1597 (invoke-restart 'ensure-failed condition
)
1598 (warn condition
)))))
1600 (defun report-test-problem (problem-type result suite method condition
1604 (options (getf (test-data suite
) :options
))
1606 (declare (ignore docs option
))
1607 (cond ((and (eq problem-type
'test-failure
)
1608 (not (typep condition
'unexpected-success-failure
))
1609 (member :expected-failure options
))
1610 (setf problem-type
'test-expected-failure
1611 option
:expected-failure
))
1612 ((and (eq problem-type
'test-error
)
1613 (member :expected-error
(getf (test-data suite
) :options
)))
1614 (setf problem-type
'test-expected-error
1615 option
:expected-error
))
1616 ((and (or (eq problem-type
'test-failure
)
1617 (eq problem-type
'test-error
))
1618 (member :expected-problem
(getf (test-data suite
) :options
)))
1619 (setf problem-type
(or (and (eq problem-type
'test-failure
)
1620 'test-expected-failure
)
1621 (and (eq problem-type
'test-error
)
1622 'test-expected-error
))
1623 option
:expected-problem
)))
1624 (let ((problem (apply #'make-instance problem-type
1627 :test-condition condition
1628 :test-step
(current-step suite
) args
)))
1629 (setf (getf (test-data suite
) :problem
) problem
)
1631 (test-failure (push problem
(failures result
)))
1632 (test-expected-failure (push problem
(expected-failures result
)))
1633 (test-error (push problem
(errors result
)))
1634 (test-expected-error (push problem
(expected-errors result
))))
1637 ;;; ---------------------------------------------------------------------------
1638 ;;; test-result and printing
1639 ;;; ---------------------------------------------------------------------------
1641 (defun get-test-print-length ()
1642 (let ((foo *test-print-length
*))
1643 (if (eq foo
:follow-print
) *print-length
* foo
)))
1645 (defun get-test-print-level ()
1646 (let ((foo *test-print-level
*))
1647 (if (eq foo
:follow-print
) *print-level
* foo
)))
1649 (defmethod start-test ((result test-result
) (case test-mixin
) name
)
1650 (push (list (type-of case
) name nil
) (tests-run result
))
1651 (setf (current-step case
) :start-test
1653 `(:start-time
,(get-internal-real-time)
1654 :start-time-universal
,(get-universal-time))))
1656 (defmethod end-test ((result test-result
) (testsuite test-mixin
) name
)
1657 (declare (ignore name
))
1658 (setf (current-step testsuite
) :end-test
1659 (getf (test-data testsuite
) :end-time
) (get-internal-real-time)
1660 (end-time result
) (get-internal-real-time)
1661 (getf (test-data testsuite
) :end-time-universal
) (get-universal-time)
1662 (end-time-universal result
) (get-universal-time)))
1664 (defun make-test-result (for test-mode
)
1665 (make-instance 'test-result
1667 :test-mode test-mode
))
1669 (defun testing-interactively-p ()
1672 (defmethod print-object ((tr test-result
) stream
)
1673 (let ((complete-success?
(and (null (errors tr
))
1674 (null (failures tr
))
1675 (null (expected-failures tr
))
1676 (null (expected-errors tr
)))))
1677 (let* ((*print-level
* (get-test-print-level))
1678 (*print-length
* (get-test-print-length)))
1679 (print-unreadable-object (tr stream
)
1680 (cond ((null (tests-run tr
))
1681 (format stream
"~A: no tests defined" (results-for tr
)))
1682 ((eq (test-mode tr
) :single
)
1683 (cond ((test-interactive? tr
)
1685 (cond (complete-success?
1686 (format stream
"Test passed"))
1688 (format stream
"Error during testing"))
1689 ((expected-errors tr
)
1690 (format stream
"Expected error during testing"))
1692 (format stream
"Test failed"))
1694 (format stream
"Test failed expectedly"))))
1697 (format stream
"~A.~A ~A"
1699 (first (first (tests-run tr
)))
1700 (cond (complete-success?
1706 (when (or (expected-errors tr
) (expected-failures tr
))
1707 (format stream
"(~[~:;, ~:*~A expected failure~:P~]~[~:;, ~:*~A expected error~:P~])"
1708 (expected-failures tr
) (expected-errors tr
))))))
1710 ;; multiple tests run
1711 (format stream
"Results for ~A " (results-for tr
))
1712 (if complete-success?
1713 (format stream
"[~A Successful test~:P]"
1714 (length (tests-run tr
)))
1715 (format stream
"~A Test~:P~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Error~:P~]~[~:;, ~:*~A Expected failure~:P~]~[~:;, ~:*~A Expected error~:P~]"
1716 (length (tests-run tr
))
1717 (length (failures tr
))
1718 (length (errors tr
))
1719 (length (expected-failures tr
))
1720 (length (expected-errors tr
))))))
1721 ;; note that suites with no tests think that they are completely
1722 ;; successful. Optimistic little buggers, huh?
1723 (when (and (not complete-success?
) *test-describe-if-not-successful?
*)
1724 (format stream
"~%")
1725 (print-test-result-details stream tr
))))))
1727 (defmethod describe-object ((result test-result
) stream
)
1728 (let ((number-of-failures (length (failures result
)))
1729 (number-of-expected-failures (length (expected-failures result
)))
1730 (number-of-errors (length (errors result
)))
1731 (number-of-expected-errors (length (expected-errors result
))))
1732 (unless *test-is-being-defined?
*
1733 (format stream
"~&Test Report for ~A: ~D test~:P run"
1734 (results-for result
) (length (tests-run result
))))
1735 (let* ((*print-level
* (get-test-print-level))
1736 (*print-length
* (get-test-print-length)))
1737 (cond ((or (failures result
) (errors result
)
1738 (expected-failures result
) (expected-errors result
))
1739 (format stream
"~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Expected failure~:P~]~[~:;, ~:*~A Error~:P~]~[~:;, ~:*~A Expected error~:P~]."
1741 number-of-expected-failures
1743 number-of-expected-errors
)
1744 (format stream
"~%~%")
1745 (print-test-result-details stream result
))
1746 ((or (expected-failures result
) (expected-errors result
))
1747 (format stream
", all passed *~[~:;, ~:*~A Expected failure~:P~]~[~:;, ~:*~A Expected error~:P~])."
1748 number-of-expected-failures
1749 number-of-expected-errors
)
1750 (format stream
"~%~%")
1751 (print-test-result-details stream result
))
1753 (unless *test-is-being-defined?
*
1754 (format stream
", all passed!")))))
1757 (defun print-test-result-details (stream result
)
1758 (loop for report in
(failures result
) do
1759 (print-test-problem "Failure: " report stream
))
1760 (loop for report in
(errors result
) do
1761 (print-test-problem "ERROR : " report stream
))
1762 (loop for report in
(expected-failures result
) do
1763 (print-test-problem "Expected failure: " report stream
))
1764 (loop for report in
(expected-errors result
) do
1765 (print-test-problem "Expected Error : " report stream
)))
1767 (defun print-test-problem (prefix report stream
)
1768 (let* ((suite (testsuite report
))
1769 (method (test-method report
))
1770 (condition (test-condition report
))
1771 (code (test-report-code suite method
))
1772 (testsuite-name method
))
1773 (format stream
"~&~A~(~A : ~A~)" prefix
(type-of suite
) testsuite-name
)
1774 (let ((doc-string (gethash testsuite-name
1775 (test-case-documentation
1776 (class-name (class-of suite
))))))
1778 (format stream
"~&~A" doc-string
)))
1779 (format stream
"~&~< ~@;~
1780 ~@[Condition: ~<~@;~A~:>~]~
1782 ~&~:>" (list (list condition
) code
))))
1785 ;;; ---------------------------------------------------------------------------
1787 ;;; ---------------------------------------------------------------------------
1789 (defclass test-problem-mixin
()
1790 ((testsuite :initform nil
:initarg
:testsuite
:reader testsuite
)
1791 (test-method :initform nil
:initarg
:test-method
:reader test-method
)
1792 (test-condition :initform nil
1793 :initarg
:test-condition
1794 :reader test-condition
)
1795 (test-problem-kind :reader test-problem-kind
:allocation
:class
)
1796 (test-step :initform nil
:initarg
:test-step
:reader test-step
)))
1798 (defmethod print-object ((problem test-problem-mixin
) stream
)
1799 (print-unreadable-object (problem stream
)
1800 (format stream
"TEST-~@:(~A~): ~A in ~A"
1801 (test-problem-kind problem
)
1802 (name (testsuite problem
))
1803 (test-method problem
))))
1805 (defclass generic-problem
(test-problem-mixin)
1806 ((test-problem-kind :initarg
:test-problem-kind
1807 :allocation
:class
)))
1809 (defclass expected-problem-mixin
()
1810 ((documentation :initform nil
1811 :initarg
:documentation
1812 :accessor failure-documentation
)))
1814 (defclass test-expected-failure
(expected-problem-mixin generic-problem
)
1817 :test-problem-kind
"Expected failure"))
1819 (defclass test-failure
(generic-problem)
1822 :test-problem-kind
"failure"))
1824 (defclass test-error-mixin
(generic-problem)
1825 ((backtrace :initform nil
:initarg
:backtrace
:reader backtrace
)))
1827 (defclass test-expected-error
(expected-problem-mixin test-error-mixin
)
1830 :test-problem-kind
"Expected error"))
1832 (defclass test-error
(test-error-mixin)
1835 :test-problem-kind
"Error"))
1837 (defmethod test-report-code ((testsuite test-mixin
) (method symbol
))
1838 (let* ((class-name (class-name (class-of testsuite
))))
1840 (test-name->code-table class-name
))))
1842 ;;; ---------------------------------------------------------------------------
1844 ;;; ---------------------------------------------------------------------------
1846 (defun remove-test-methods (test-name)
1848 (length (testsuite-tests test-name
))
1849 (setf (testsuite-tests test-name
) nil
)))
1851 (defun remove-previous-definitions (classname)
1852 "Remove the methods of this class and all its subclasses."
1853 (let ((classes-removed nil
)
1854 (class (find-class classname nil
))
1857 (loop for subclass in
(subclasses class
:proper? nil
) do
1858 (push subclass classes-removed
)
1860 (remove-test-methods (class-name subclass
)))
1862 ;;?? causing more trouble than it solves...??
1863 (setf (find-class (class-name subclass
)) nil
))
1865 (unless (length-1-list-p classes-removed
)
1867 "~&;;; Removed Test suite ~(~A~) and its subclasses (~{~<~s~>~^, ~})."
1870 (mapcar #'class-name classes-removed
))
1872 (unless (zerop removed-count
)
1874 "~&;;; Removed ~D methods from test suite ~(~A~)~@[ and its subclasses~]."
1875 removed-count classname
1876 (not (length-1-list-p classes-removed
)))))))
1878 (defun build-initialize-test-method ()
1879 (let ((initforms nil
)
1881 (slot-specs (def :slot-specs
)))
1882 (loop for slot in slot-specs do
1883 (when (and (member :initform
(rest slot
))
1884 (not (eq :unbound
(getf (rest slot
) :initform
))))
1885 (push (getf (rest slot
) :initform
) initforms
)
1886 (push (first slot
) slot-names
)))
1887 (setf slot-names
(nreverse slot-names
)
1888 initforms
(nreverse initforms
))
1890 `((defmethod make-single-prototype ((testsuite ,(def :testsuite-name
)))
1893 (when (next-method-p)
1895 (let* (,@(mapcar (lambda (slot-name initform
)
1896 `(,slot-name
,initform
))
1897 slot-names initforms
))
1898 (list ,@(mapcar (lambda (slot-name)
1899 `(cons ',slot-name
,slot-name
))
1900 slot-names
))))))))))
1902 (defun (setf test-environment-value
) (value name
)
1903 (pushnew (cons name value
) *test-environment
* :test
#'equal
)
1906 (defun test-environment-value (name)
1907 (cdr (assoc name
*test-environment
*)))
1909 (defun remove-from-test-environment (name)
1910 (setf *test-environment
*
1911 (remove name
*test-environment
* :key
#'car
)))
1913 (defun build-test-local-functions ()
1916 (lambda (function-spec)
1917 (destructuring-bind (name arglist
&body body
) (first function-spec
)
1918 `(defmethod flet-test-function ((testsuite ,(def :testsuite-name
))
1919 (function-name (eql ',name
))
1923 `(destructuring-bind ,arglist args
1925 `(progn ,@body
))))))
1928 (defun build-test-teardown-method ()
1929 (let ((test-name (def :testsuite-name
))
1930 (slot-names (def :direct-slot-names
))
1931 (teardown (def :teardown
)))
1933 (unless (consp teardown
)
1934 (setf teardown
(list teardown
)))
1935 (when (length-1-list-p teardown
)
1936 (setf teardown
(list teardown
)))
1937 (when (symbolp (first teardown
))
1938 (setf teardown
(list teardown
))))
1939 (let* ((teardown-code `(,@(when teardown
1940 `((with-test-slots ,@teardown
)))))
1941 (test-code `(,@teardown-code
1942 ,@(mapcar (lambda (slot)
1943 `(remove-from-test-environment ',slot
))
1946 ,@(when teardown-code
1947 `((defmethod teardown-test progn
((testsuite ,test-name
))
1948 (when (run-teardown-p testsuite
:test-case
)
1950 ,@(when teardown-code
1951 `((defmethod testsuite-teardown ((testsuite ,test-name
)
1952 (result test-result
))
1953 (when (run-teardown-p testsuite
:testsuite
)
1956 (defun build-setup-test-method ()
1957 (let ((test-name (def :testsuite-name
))
1958 (setup (def :setup
)))
1960 (unless (consp setup
)
1961 (setf setup
(list setup
)))
1962 (when (length-1-list-p setup
)
1963 (setf setup
(list setup
)))
1964 (when (symbolp (first setup
))
1965 (setf setup
(list setup
)))
1966 (let ((code `((with-test-slots ,@setup
))))
1968 (defmethod setup-test :after
((testsuite ,test-name
))
1971 (defmethod setup-test :around
((test test-mixin
))
1972 (when (run-setup-p test
)
1974 (setf (slot-value test
'done-setup?
) t
)))
1976 (defun run-setup-p (testsuite)
1977 (case (run-setup testsuite
)
1978 (:once-per-session
(error "not implemented"))
1979 (:once-per-suite
(not (done-setup? testsuite
)))
1980 ((:once-per-test-case t
) t
)
1982 (t (error "Don't know about ~s for run-setup" (run-setup testsuite
)))))
1984 (defun run-teardown-p (testsuite when
)
1987 (ecase (run-setup testsuite
)
1988 (:once-per-session nil
)
1989 (:once-per-suite nil
)
1990 ((:once-per-test-case t
) t
)
1991 ((:never nil
) nil
)))
1993 (ecase (run-setup testsuite
)
1994 (:once-per-session nil
)
1996 ((:once-per-test-case t
) nil
)
1997 ((:never nil
) nil
)))))
1999 (defun build-test-test-method (test-class test-body options
)
2000 (multiple-value-bind (test-name body documentation name-supplied?
)
2001 (parse-test-body test-body
)
2002 (declare (ignorable name-supplied?
))
2003 (unless (consp (first body
))
2004 (setf body
(list body
)))
2006 (setf (gethash ',test-name
(test-name->code-table
',test-class
)) ',body
2007 (gethash ',body
(test-code->name-table
',test-class
)) ',test-name
)
2008 ,(when documentation
2009 `(setf (gethash ',test-name
(test-case-documentation ',test-class
))
2012 ,@(when name-supplied?
2013 `((ccl:record-source-file
',test-name
'test-case
)))
2014 (unless (find ',test-name
(testsuite-tests ',test-class
))
2015 (setf (testsuite-tests ',test-class
)
2016 (append (testsuite-tests ',test-class
) (list ',test-name
))))
2017 (defmethod lift-test ((testsuite ,test-class
) (case (eql ',test-name
)))
2019 `((setf (getf (test-data testsuite
) :options
) ',options
)))
2020 (with-test-slots ,@body
))
2021 (setf *current-case-method-name
* ',test-name
)
2022 (when (and *test-print-when-defined?
*
2023 (not (or *test-is-being-compiled?
*
2025 (format *debug-io
* "~&;Test Created: ~(~S.~S~)."
2026 ',test-class
',test-name
))
2027 *current-case-method-name
*)))
2029 (defun build-dynamics ()
2031 (dolist (putative-pair (def :dynamic-variables
))
2032 (if (atom putative-pair
)
2033 (push (list putative-pair nil
) result
)
2034 (push putative-pair result
)))
2037 (defun parse-test-body (test-body)
2038 (let ((test-name nil
)
2042 (test-number (1+ (testsuite-test-count *current-suite-class-name
*)))
2043 (name-supplied? nil
))
2044 ;; parse out any documentation
2045 (loop for form in test-body do
2046 (if (and (consp form
)
2047 (keywordp (first form
))
2048 (eq :documentation
(first form
)))
2049 (setf documentation
(second form
))
2050 (push form parsed-body
)))
2051 (setf test-body
(nreverse parsed-body
))
2052 (setf test-name
(first test-body
))
2053 (cond ((symbolp test-name
)
2055 (intern (format nil
"~A" test-name
))
2056 body
(rest test-body
)
2058 ((and (test-code->name-table
*current-suite-class-name
*)
2061 (test-code->name-table
*current-suite-class-name
*))))
2062 (setf body test-body
))
2065 (intern (format nil
"TEST-~A"
2068 (values test-name body documentation name-supplied?
)))
2070 (defun build-test-class ()
2071 ;; for now, we don't generate code from :class-def code-blocks
2072 ;; they are executed only for effect.
2073 (loop for
(nil . block
) in
*code-blocks
*
2076 (eq (operate-when block
) :class-def
)
2077 (or (not (filter block
))
2078 (funcall (filter block
)))) collect
2079 (funcall (code block
)))
2080 (unless (some (lambda (superclass)
2081 (testsuite-p superclass
))
2082 (def :superclasses
))
2083 (pushnew 'test-mixin
(def :superclasses
)))
2084 ;; build basic class and standard class
2085 `(defclass ,(def :testsuite-name
) (,@(def :superclasses
))
2087 ,@(when (def :documentation
)
2088 `((:documentation
,(def :documentation
))))
2090 :test-slot-names
',(def :slot-names
)
2091 ,@(def :default-initargs
))))
2093 (defun parse-test-slots (slot-specs)
2094 (loop for spec in slot-specs collect
2095 (let ((parsed-spec spec
))
2096 (if (member :initform parsed-spec
)
2097 (let ((pos (position :initform parsed-spec
)))
2098 (append (subseq parsed-spec
0 pos
)
2099 (subseq parsed-spec
(+ pos
2))))
2102 (defmethod testsuite-p ((classname symbol
))
2103 (let ((class (find-class classname nil
)))
2106 (typep (allocate-instance class
) 'test-mixin
)
2108 (error (c) (declare (ignore c
)) (values nil
)))))
2110 (defmethod testsuite-p ((object standard-object
))
2111 (testsuite-p (class-name (class-of object
))))
2113 (defmethod testsuite-p ((class standard-class
))
2114 (testsuite-p (class-name class
)))
2116 (defmethod testsuite-methods ((classname symbol
))
2117 (testsuite-tests classname
))
2119 (defmethod testsuite-methods ((test test-mixin
))
2120 (testsuite-methods (class-name (class-of test
))))
2122 (defmethod testsuite-methods ((test standard-class
))
2123 (testsuite-methods (class-name test
)))
2126 ;; some handy properties
2127 (defclass-property test-slots
)
2128 (defclass-property test-code-
>name-table
)
2129 (defclass-property test-name-
>code-table
)
2130 (defclass-property test-case-documentation
)
2131 (defclass-property testsuite-prototype
)
2132 (defclass-property testsuite-tests
)
2133 (defclass-property testsuite-dynamic-variables
)
2135 ;;?? issue 27: break encapsulation of code blocks
2136 (defclass-property testsuite-function-specs
)
2138 (defun empty-test-tables (test-name)
2139 (when (find-class test-name nil
)
2140 (setf (test-code->name-table test-name
)
2141 (make-hash-table :test
#'equal
)
2142 (test-name->code-table test-name
)
2143 (make-hash-table :test
#'equal
)
2144 (test-case-documentation test-name
)
2145 (make-hash-table :test
#'equal
))))
2148 (define-condition timeout-error
(error)
2150 (:report
(lambda (c s
)
2151 (declare (ignore c
))
2152 (format s
"Process timeout"))))
2154 (defmacro with-timeout
((seconds) &body body
)
2156 `(mp:with-timeout
(,seconds
(error 'timeout-error
))
2159 `(mp:with-timeout
(,seconds
) ,@body
)
2162 (sb-ext:with-timeout
,seconds
,@body
)
2163 (sb-ext::timeout
(c)
2164 (cerror "Timeout" 'timeout-error
)))
2165 #+(or digitool openmcl
)
2166 (let ((checker-process (format nil
"Checker ~S" (gensym)))
2167 (waiting-process (format nil
"Waiter ~S" (gensym)))
2170 `(let* ((,result nil
)
2171 (,process
(ccl:process-run-function
2174 (setf ,result
(progn ,@body
))))))
2175 (ccl:process-wait-with-timeout
2177 (* ,seconds
#+openmcl ccl
:*ticks-per-second
* #+digitool
60)
2179 (not (ccl::process-active-p
,process
))))
2180 (when (ccl::process-active-p
,process
)
2181 (ccl:process-kill
,process
)
2182 (cerror "Timeout" 'timeout-error
))
2184 #-
(or allegro cmu sb-thread openmcl digitool
)
2187 (defvar *test-maximum-time
* 2
2188 "Maximum number of seconds a process test is allowed to run before we give up.")
2190 (pushnew :timeout
*deftest-clauses
*)
2193 :timeout
1 :class-def
2194 (lambda () (def :timeout
))
2195 '((setf (def :timeout
) (cleanup-parsed-parameter value
)))
2197 (unless (some (lambda (super)
2198 (member (find-class 'process-test-mixin
)
2199 (superclasses super
)))
2200 (def :superclasses
))
2201 (pushnew 'process-test-mixin
(def :superclasses
)))
2202 (push (def :timeout
) (def :default-initargs
))
2203 (push :maximum-time
(def :default-initargs
))
2206 (defclass process-test-mixin
()
2207 ((maximum-time :initform
*test-maximum-time
*
2208 :accessor maximum-time
2209 :initarg
:maximum-time
)))
2211 (defclass test-timeout-failure
(test-failure)
2212 ((test-problem-kind :initform
"Timeout" :allocation
:class
)))
2214 (define-condition test-timeout-condition
(test-condition)
2215 ((maximum-time :initform
*test-maximum-time
*
2216 :accessor maximum-time
2217 :initarg
:maximum-time
))
2218 (:report
(lambda (c s
)
2219 (format s
"Test ran out of time (longer than ~S-second~:P)"
2220 (maximum-time c
)))))
2222 (defmethod do-testing :around
((testsuite process-test-mixin
) result fn
)
2223 (declare (ignore fn
))
2225 (with-timeout ((maximum-time testsuite
))
2229 (declare (ignore c
))
2230 (report-test-problem
2231 'test-timeout-failure result testsuite
(current-method testsuite
)
2232 (make-instance 'test-timeout-condition
2233 :maximum-time
(maximum-time testsuite
))))))
2237 (defmethod find-testsuite ((suite symbol
))
2238 (or (testsuite-p suite
)
2239 (find-testsuite (symbol-name suite
))))
2241 (defmethod find-testsuite ((suite-name string
))
2243 (possibilities (remove-duplicates
2244 (loop for p in
(list-all-packages)
2245 when
(and (setf temp
(find-symbol suite-name p
))
2246 (find-class temp nil
)
2247 (subtypep temp
'test-mixin
)) collect
2249 (cond ((null possibilities
)
2250 (error 'test-class-not-defined
:test-class-name suite-name
))
2251 ((= (length possibilities
) 1)
2252 (first possibilities
))
2254 (error "There are several test suites named ~s: they are ~{~s~^, ~}"
2255 suite-name possibilities
)))))
2257 (defun test-case-p (suite-class name
)
2258 (find-method #'lift-test nil
`(,suite-class
(eql ,name
)) nil
))
2262 (find-class (find-testsuite 'test-cluster-indexing-locally
) nil
)
2263 'db.agraph.tests
::index-them
)
2266 (find-test-case (find-class (find-testsuite 'test-cluster-indexing-locally
))
2269 (defmethod find-test-case ((suite symbol
) name
)
2270 (find-test-case (find-class (find-testsuite suite
)) name
))
2272 (defmethod find-test-case ((suite test-mixin
) name
)
2273 (find-test-case (class-of suite
) name
))
2275 (defmethod find-test-case ((suite-class standard-class
) (name symbol
))
2276 (or (and (test-case-p suite-class name
) name
)
2277 (find-test-case suite-class
(symbol-name name
))))
2279 (defmethod find-test-case ((suite test-mixin
) (name string
))
2280 (find-test-case (class-of suite
) name
))
2282 (defmethod find-test-case ((suite-class standard-class
) (name string
))
2284 (possibilities (remove-duplicates
2285 (loop for p in
(list-all-packages)
2286 when
(and (setf temp
(find-symbol name p
))
2287 (test-case-p suite-class temp
)) collect
2289 (cond ((null possibilities
)
2290 (error 'test-class-not-defined
:test-class-name name
))
2291 ((= (length possibilities
) 1)
2292 (first possibilities
))
2294 (error "There are several test cases of ~s named ~s: they are ~{~s~^, ~}"
2295 suite-class name possibilities
)))))
2297 (defun last-test-status ()
2298 (cond ((typep *test-result
* 'test-result
)
2299 (cond ((and (null (errors *test-result
*))
2300 (null (failures *test-result
*)))
2302 ((and (errors *test-result
*)
2303 (failures *test-result
*))
2304 :errors-and-failures
)
2305 ((errors *test-result
*)
2307 ((failures *test-result
*)
2312 (defun suite-tested-p (suite &key
(result *test-result
*))
2314 (typep *test-result
* 'test-result
)
2315 (slot-exists-p result
'suites-run
)
2316 (slot-boundp result
'suites-run
)
2317 (consp (suites-run result
))
2318 (find suite
(suites-run result
))))
2320 (defun unique-filename (pathname)
2321 (let ((date-part (date-stamp)))
2327 :name
(format nil
"~a-~a-~d"
2328 (pathname-name pathname
)
2331 (unless (probe-file name
)
2332 (return-from unique-filename name
)))
2333 (error "Unable to find unique pathname for ~a" pathname
)))
2335 (defun date-stamp (&key
(datetime (get-universal-time)) (include-time? nil
))
2336 (multiple-value-bind
2337 (second minute hour day month year day-of-the-week
)
2338 (decode-universal-time datetime
)
2339 (declare (ignore day-of-the-week
))
2340 (let ((date-part (format nil
"~d-~2,'0d-~2,'0d" year month day
))
2341 (time-part (and include-time?
2342 (list (format nil
"-~2,'0d-~2,'0d-~2,'0d"
2343 hour minute second
)))))
2344 (apply 'concatenate
'string date-part time-part
))))
2347 (date-stamp :include-time? t
)
2349 ;;?? might be "cleaner" with a macrolet (cf. lift-result)
2350 (defun lift-property (name)
2351 (when *current-test
*
2352 (getf (getf (test-data *current-test
*) :properties
) name
)))
2355 (setf (getf (getf (third (first (tests-run *test-result
*))) :properties
) :foo
)
2358 (defun (setf lift-property
) (value name
)
2359 (when *current-test
*
2360 (setf (getf (getf (test-data *current-test
*) :properties
) name
) value
)))
