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
*
63 ensure-random-cases-failure
64 random-instance-for-suite
78 ;;; ---------------------------------------------------------------------------
80 ;;; ---------------------------------------------------------------------------
82 (defgeneric get-class
(thing &key error?
)
83 (: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.")
84 (:method
((thing symbol
) &key error?
)
85 (find-class thing error?
))
86 (:method
((thing standard-object
) &key error?
)
87 (declare (ignore error?
))
89 (:method
((thing t
) &key error?
)
90 (declare (ignore error?
))
92 (:method
((thing class
) &key error?
)
93 (declare (ignore error?
))
96 (defun direct-subclasses (thing)
97 "Returns the immediate subclasses of thing. Thing can be a class, object or symbol naming a class."
98 (class-direct-subclasses (get-class thing
)))
100 (defun map-subclasses (class fn
&key proper?
)
101 "Applies fn to each subclass of class. If proper? is true, then
102 the class itself is not included in the mapping. Proper? defaults to nil."
103 (let ((mapped (make-hash-table :test
#'eq
)))
104 (labels ((mapped-p (class)
105 (gethash class mapped
))
107 (unless (mapped-p class
)
108 (setf (gethash class mapped
) t
)
109 (unless (and proper? root
)
111 (mapc (lambda (class)
113 (direct-subclasses class
)))))
114 (do-it (get-class class
) t
))))
116 (defun subclasses (class &key
(proper? t
))
117 "Returns all of the subclasses of the class including the class itself."
119 (map-subclasses class
(lambda (class)
124 (defun superclasses (thing &key
(proper? t
))
125 "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."
126 (let ((result (class-precedence-list (get-class thing
))))
127 (if proper?
(rest result
) result
)))
129 (defun direct-superclasses (thing)
130 "Returns the immediate superclasses of thing. Thing can be a class, object or symbol naming a class."
131 (class-direct-superclasses (get-class thing
)))
133 (declaim (inline length-1-list-p
))
134 (defun length-1-list-p (x)
135 "Is x a list of length 1?"
136 (and (consp x
) (null (cdr x
))))
138 (defmacro defclass-property
(property &optional
(default nil default-supplied?
))
139 "Create getter and setter methods for 'property' on symbol's property lists."
140 (let ((real-name (intern (format nil
"~:@(~A~)" property
) :keyword
)))
142 (defgeneric ,property
(symbol))
143 (defgeneric (setf ,property
) (value symbol
))
144 (defmethod ,property
((class-name symbol
))
145 (get class-name
,real-name
,@(when default-supplied?
(list default
))))
146 (defmethod (setf ,property
) (value (class-name symbol
))
147 (setf (get class-name
,real-name
) value
)))))
149 (defvar *automatic-slot-accessors?
* nil
)
150 (defvar *automatic-slot-initargs?
* nil
)
151 (defvar *clos-slot-options
*
152 '(:initform
:initarg
:reader
:writer
153 :accessor
:documentation
:type
156 ;;; ---------------------------------------------------------------------------
158 (defun parse-brief-slot
160 (automatic-accessors?
*automatic-slot-accessors?
*)
161 (automatic-initargs?
*automatic-slot-initargs?
*)
163 (conc-separator "-"))
164 "Returns a verbose-style slot specification given a brief style, consisting of
165 a single symbol, the name of the slot, or a list of the slot name, optional
166 initform, optional symbol specifying whether there is an initarg, reader, or
167 accessor, and optional documentation string. The specification of initarg,
168 reader and accessor is done by the letters I, R and A, respectively; to specify
169 none of those, give a symbol containing none of those letters, such as the
170 symbol *. This function is used in the macro `defclass-brief,' but has been
171 broken out as a function in its own right for those writing variants on the
172 `defclass' macro. If a verbose-style slot specification is given, it is
175 If `automatic-accessors? is true, an accessor is defined, whether A is
176 specified or not _unless_ R is specified. If `automatic-initargs? is true,
177 an initarg is defined whether I is specified or not. If `conc-name' is
178 specified, the accessor name has that prepended, with conc-separator, and then
181 All other CLOS slot options are processed normally."
185 (symbol (setf slot
(list slot
)))
188 (let* ((name (pop slot
))
189 (new-slot (list name
))
192 (done-documentation? nil
)
194 (accessor-added? nil
)
195 (initargs-added? nil
))
196 (flet ((make-conc-name ()
198 (intern (format nil
"~@:(~A~A~A~)"
199 conc-name conc-separator name
))
202 (add-option (option argument
)
203 (push option new-slot
)
204 (push argument new-slot
))
206 ;; Remove duplicate options before returning the slot spec.
207 (finish-new-slot (slot)
208 ;; XXX This code is overly loopy and opaque ---L
209 (destructuring-bind (slot-name &rest options
) slot
210 (let ((opts (make-hash-table)))
211 (loop for
(key val . d
) = options then d
213 doing
(pushnew val
(gethash key opts nil
) :test
#'equal
))
214 (loop for key being each hash-key of opts using
(hash-value vals
)
215 nconc
(mapcan #'(lambda (x) (list key x
)) vals
) into spec
216 finally
(return (cons slot-name spec
)))))))
218 (do* ((items slot
(rest items
))
219 (item (first items
) (first items
))
221 (clos-item?
(member item
*clos-slot-options
*)
222 (member item
*clos-slot-options
*)))
225 (unless done-initform?
226 (setf done-initform? t
)
228 (setf process-item? nil
)
229 (unless (eq item
:UNBOUND
)
230 (push :initform new-slot
)
231 (push item new-slot
))))
234 (unless (or done-spec?
(not (symbolp item
)) clos-item?
)
236 (setf process-item? nil
)
237 ;; If you've got an A, who cares about R
238 (when (find #\A
(string item
))
239 (setf accessor-added? t
)
240 (add-option :accessor
(make-conc-name)))
241 (when (and (not accessor-added?
) (find #\R
(string item
)))
242 (setf reader-added? t
)
243 (add-option :reader
(make-conc-name)))
244 (when (find #\I
(string item
))
245 (setf initargs-added? t
)
246 (add-option :initarg
(intern (string name
)
247 (find-package :keyword
))))))
250 (unless (or done-documentation?
(not (stringp item
)))
251 (setf done-documentation? t
)
252 (push :documentation new-slot
)
260 (push (first items
) new-slot
))))
262 (when (and automatic-initargs?
(not initargs-added?
))
263 (add-option :initarg
(intern (string name
) (find-package :keyword
))))
265 (when (and automatic-accessors?
266 (and (not accessor-added?
) (not reader-added?
)))
267 (add-option :accessor
(make-conc-name)))
269 ;; finish-new-slot cleans up duplicates
270 (finish-new-slot (nreverse new-slot
)))))
272 ;;; ---------------------------------------------------------------------------
274 (defun convert-clauses-into-lists (clauses-and-options clauses-to-convert
)
275 ;; This is useful (for me at least!) for writing macros
276 (let ((parsed-clauses nil
))
277 (do* ((clauses clauses-and-options
(rest clauses
))
278 (clause (first clauses
) (first clauses
)))
280 (if (and (keywordp clause
)
281 (or (null clauses-to-convert
) (member clause clauses-to-convert
))
282 (not (length-1-list-p clauses
)))
284 (setf clauses
(rest clauses
))
285 (push (list clause
(first clauses
)) parsed-clauses
))
286 (push clause parsed-clauses
)))
287 (nreverse parsed-clauses
)))
289 (defun remove-leading-quote (list)
290 "Removes the first quote from a list if one is there."
291 (if (and (consp list
) (eql (first list
) 'quote
))
295 (defun cleanup-parsed-parameter (parameter)
296 (if (length-1-list-p parameter
)
300 ;;; ---------------------------------------------------------------------------
301 ;;; global environment thingies
302 ;;; ---------------------------------------------------------------------------
304 (defparameter *make-testsuite-arguments
*
305 '(:run-setup
:test-slot-names
:equality-test
:log-file
:timeout
))
307 (defvar *current-suite-class-name
* nil
)
308 (defvar *current-case-method-name
* nil
)
310 (defvar *test-is-being-defined?
* nil
)
311 (defvar *test-is-being-compiled?
* nil
)
312 (defvar *test-is-being-loaded?
* nil
)
313 (defvar *test-is-being-executed?
* nil
)
315 (defvar *testsuite-test-count
* nil
316 "Temporary variable used to 'communicate' between deftestsuite and addtest.")
317 (defvar *lift-debug-output
* *debug-io
*
318 "Messages from LIFT will be sent to this stream. It can set to nil or to an output stream. It defaults to *debug-io*.")
320 (defvar *test-break-on-errors?
* nil
)
321 (defvar *test-do-children?
* t
)
322 (defparameter *test-ignore-warnings?
* nil
323 "If true, LIFT will not cause a test to fail if a warning occurs while the test is running. Note that this may interact oddly with ensure-warning.")
324 (defparameter *test-print-when-defined?
* nil
)
325 (defparameter *test-evaluate-when-defined?
* t
)
326 (defparameter *test-scratchpad
* nil
327 "A place to put things. This is set to nil before every test.")
328 (defparameter *test-notepad
* nil
329 "Another place to put things (set {ref *test-scratchpad*}.")
331 (defparameter *lift-equality-test
* 'equal
332 "The function used in ensure-same to test if two things are equal. If metatilities is loaded, then you might want to use samep.")
334 (defvar *test-describe-if-not-successful?
* nil
335 ;; Was t, but this behavior was extremely annoying since each
336 ;; time a test-restul appears in a stack backtrace it is printed
337 ;; over many unstructured lines.
338 "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.")
340 (defvar *test-print-length
* :follow-print
341 "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*`.")
342 (defvar *test-print-level
* :follow-print
343 "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.")
345 (defvar *test-print-testsuite-names
* t
346 "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*.")
348 (defvar *test-print-test-case-names
* nil
349 "If true, LIFT will print the name of each test-case before it runs. See also: *test-print-testsuite-names*.")
351 (defvar *test-result
* nil
352 "Set to the most recent test result by calls to run-test or run-tests.")
354 (defvar *test-environment
* nil
)
356 (defvar *test-metadata
* (list)
357 "A place for LIFT to put stuff.")
359 (defvar *current-test
* nil
360 "The current testsuite.")
362 (defvar *lift-dribble-pathname
* nil
363 "If bound, then test output from run-tests will be sent to this file 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 to an output stream. It defaults to *standard-output*.")
368 (defvar *lift-if-dribble-exists
* :append
369 "Specifies what to do to any existing file at *lift-dribble-pathname*. It can be :supersede, :append, or :error.")
371 ;;; ---------------------------------------------------------------------------
372 ;;; Error messages and warnings
373 ;;; ---------------------------------------------------------------------------
375 (defparameter +lift-test-name-not-supplied-with-test-class
+
376 "if you specify a test-class, you must also specify a test-name.")
378 (defparameter +lift-test-class-not-found
+
379 "test class '~S' not found.")
381 (defparameter +lift-confused-about-arguments
+
382 "I'm confused about what you said?!")
384 (defparameter +lift-no-current-test-class
+
385 "There is no current-test-class to use as a default.")
387 (defparameter +lift-could-not-find-test
+
388 "Could not find test: ~S.~S")
390 (defparameter +run-tests-null-test-case
+
391 "There is no current testsuite (possibly because none have been defined yet?). You can specify the testsuite to test by evaluating (run-tests :suite <suitename>).")
393 (defparameter +lift-unable-to-parse-test-name-and-class
+
397 ;;; ---------------------------------------------------------------------------
399 ;;; ---------------------------------------------------------------------------
401 (define-condition lift-compile-error
(error)
404 :initarg
:lift-message
))
405 (:report
(lambda (c s
)
406 (format s
"Compile error: '~S'" (msg c
)))))
408 (define-condition test-class-not-defined
(lift-compile-error)
409 ((test-class-name :reader test-class-name
410 :initarg
:test-class-name
))
411 (:report
(lambda (c s
)
412 (format s
"Test class ~A not defined before it was used."
413 (test-class-name c
)))))
415 (defun build-lift-error-message (context message
&rest arguments
)
418 (apply #'format nil message arguments
)))
420 (defun signal-lift-error (context message
&rest arguments
)
421 (let ((c (make-condition
423 :lift-message
(apply #'build-lift-error-message
424 context message arguments
))))
428 (defun report-lift-error (context message
&rest arguments
)
429 (format *debug-io
* "~&~A."
430 (apply #'build-lift-error-message context message arguments
))
433 (defun lift-report-condition (c)
434 (format *debug-io
* "~&~A." c
))
436 (define-condition test-condition
(warning)
437 ((message :initform
""
440 (:report
(lambda (c s
)
442 (format s
"~%~A" (message c
))))))
444 (define-condition ensure-failed-error
(test-condition)
445 ((assertion :initform
""
447 :initarg
:assertion
))
448 (:report
(lambda (c s
)
449 (format s
"Ensure failed: ~S ~@[(~a)~]"
450 (assertion c
) (message c
)))))
452 (define-condition ensure-null-failed-error
(ensure-failed-error)
456 (assertion :initform
""
458 :initarg
:assertion
))
459 (:report
(lambda (c s
)
460 (format s
"Ensure null failed: ~s evaluates to ~s ~@[(~a)~]"
461 (assertion c
) (value c
) (message c
)))))
463 (define-condition ensure-expected-condition
(test-condition)
464 ((expected-condition-type
466 :accessor expected-condition-type
467 :initarg
:expected-condition-type
)
470 :accessor the-condition
471 :initarg
:the-condition
))
472 (:report
(lambda (c s
)
473 (format s
"Expected ~A but got ~S"
474 (expected-condition-type c
)
475 (the-condition c
)))))
477 (define-condition ensure-not-same
(test-condition)
478 ((first-value :accessor first-value
479 :initarg
:first-value
)
480 (second-value :accessor second-value
481 :initarg
:second-value
)
484 (:report
(lambda (c s
)
485 (format s
"Ensure-same: ~S is not ~S to ~S~@[ (~a)~]"
486 (first-value c
) (test c
) (second-value c
)
489 (defmacro ensure
(predicate &key report arguments
)
490 "If ensure's `predicate` evaluates to false, then it will generate a
491 test failure. You can use the `report` and `arguments` keyword parameters
492 to customize the report generated in test results. For example:
495 :report \"I hope ~a does not = ~a\"
498 will generate a message like
500 Warning: Ensure failed: (= 23 12) (I hope 12 does not = 23)
502 (let ((gpredicate (gensym)))
503 `(let ((,gpredicate
,predicate
))
506 (let ((condition (make-condition
508 :assertion
',predicate
511 (format nil
,report
,@arguments
))))))
512 (if (find-restart 'ensure-failed
)
513 (invoke-restart 'ensure-failed condition
)
514 (warn condition
)))))))
516 (defmacro ensure-null
(predicate &key report arguments
)
517 "If ensure-null's `predicate` evaluates to true, then it will generate a
518 test failure. You can use the `report` and `arguments` keyword parameters
519 to customize the report generated in test results. See [ensure][] for more
522 `(let ((,g
,predicate
))
525 (let ((condition (make-condition 'ensure-null-failed-error
527 :assertion
',predicate
529 `(:message
(format nil
,report
,@arguments
))))))
530 (if (find-restart 'ensure-failed
)
531 (invoke-restart 'ensure-failed condition
)
532 (warn condition
)))))))
534 (defmacro ensure-condition
(condition &body body
)
535 "This macro is used to make sure that body really does produce condition."
536 (setf condition
(remove-leading-quote condition
))
537 (destructuring-bind (condition &key report arguments
)
538 (if (consp condition
) condition
(list condition
))
545 (declare (ignore cond
)) (setf ,g t
))
548 (let ((c (make-condition
549 'ensure-expected-condition
550 :expected-condition-type
',condition
553 `(:message
(format nil
,report
,arguments
))))))
554 (if (find-restart 'ensure-failed
)
555 (invoke-restart 'ensure-failed c
)
558 (if (find-restart 'ensure-failed
)
562 'ensure-expected-condition
563 :expected-condition-type
',condition
566 `(:message
(format nil
,report
,arguments
)))))
567 (warn "Ensure-condition didn't get the condition it expected."))))))))
569 (defmacro ensure-warning
(&body body
)
570 "Ensure-warning evaluates its body. If the body does *not* signal a
571 warning, then ensure-warning will generate a test failure."
572 `(ensure-condition warning
,@body
))
574 (defmacro ensure-error
(&body body
)
575 "Ensure-error evaluates its body. If the body does *not* signal an
576 error, then ensure-error will generate a test failure."
577 `(ensure-condition error
,@body
))
579 (defmacro ensure-same
580 (form values
&key
(test nil test-specified-p
)
581 (report nil
) (arguments nil
))
582 "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"
583 (setf test
(remove-leading-quote test
))
584 (when (and (consp test
)
585 (eq (first test
) 'function
))
586 (setf test
(second test
)))
587 (let ((block (gensym)))
589 (loop for value in
(multiple-value-list ,form
)
590 for other-value in
(multiple-value-list ,values
) do
591 (unless (funcall ,(if test-specified-p
(list 'quote test
) '*lift-equality-test
*)
593 (maybe-raise-not-same-condition
595 ,(if test-specified-p
(list 'quote test
) '*lift-equality-test
*)
597 (return-from ,block nil
)))
600 (defmacro ensure-different
601 (form values
&key
(test nil test-specified-p
)
602 (report nil
) (arguments nil
))
603 "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"
604 ;; FIXME -- share code with ensure-same
605 (setf test
(remove-leading-quote test
))
606 (when (and (consp test
)
607 (eq (first test
) 'function
))
608 (setf test
(second test
)))
610 (loop for value in
(multiple-value-list ,form
)
611 for other-value in
(multiple-value-list ,values
) do
612 ;; WHEN instead of UNLESS
613 (when (funcall ,(if test-specified-p
615 '*lift-equality-test
*)
617 (maybe-raise-not-same-condition
619 ,(if test-specified-p
621 '*lift-equality-test
*) ,report
,@arguments
)))
624 (defun maybe-raise-not-same-condition (value-1 value-2 test
625 report
&rest arguments
)
626 (let ((condition (make-condition 'ensure-not-same
628 :second-value value-2
630 :message
(when report
632 report arguments
)))))
633 (if (find-restart 'ensure-failed
)
634 (invoke-restart 'ensure-failed condition
)
637 (define-condition ensure-cases-failure
(test-condition)
638 ((total :initarg
:total
:initform
0)
639 (problems :initarg
:problems
:initform nil
))
640 (:report
(lambda (condition stream
)
641 (format stream
"Ensure-cases: ~d out of ~d cases failed. Failing cases are: ~{~% ~{~s (~a)~}~^, ~}"
642 (length (slot-value condition
'problems
))
643 (slot-value condition
'total
)
644 (slot-value condition
'problems
)))))
646 (defmacro ensure-cases
((&rest vars
) (&rest cases
) &body body
)
647 (let ((case (gensym))
650 `(let ((,problems nil
) (,total
0))
651 (loop for
,case in
,cases do
653 (destructuring-bind ,vars
,case
656 (ensure-failed (cond)
657 (push (list ,case cond
) ,problems
)))))
659 (let ((condition (make-condition
660 'ensure-cases-failure
662 :problems
,problems
)))
663 (if (find-restart 'ensure-failed
)
664 (invoke-restart 'ensure-failed condition
)
665 (warn condition
)))))))
668 ;;; ---------------------------------------------------------------------------
670 ;;; ---------------------------------------------------------------------------
672 (defclass test-mixin
()
673 ((name :initform nil
:initarg
:name
:accessor name
:reader testsuite-name
)
674 (run-setup :reader run-setup
:initarg
:run-setup
)
675 (done-setup?
:initform nil
:reader done-setup?
)
676 (done-dynamics?
:initform nil
:reader done-dynamics?
)
677 (prototypes :initform
(list (list)) :accessor prototypes
)
678 (prototypes-initialized?
:initform nil
:reader prototypes-initialized?
)
679 (current-values :initform nil
:accessor current-values
)
680 (test-slot-names :initform nil
:initarg
:test-slot-names
681 :reader test-slot-names
)
682 (current-step :initform
:created
:accessor current-step
)
683 (current-method :initform nil
:accessor current-method
)
684 (save-equality-test :initform nil
:reader save-equality-test
)
685 (equality-test :initform
'equal
:initarg
:equality-test
686 :reader equality-test
)
687 (log-file :initform nil
:initarg
:log-file
:reader log-file
)
688 (test-data :initform nil
:accessor test-data
)
689 (expected-failure-p :initform nil
:initarg
:expected-failure-p
690 :reader expected-failure-p
)
691 (expected-error-p :initform nil
:initarg
:expected-error-p
692 :reader expected-error-p
)
693 (expected-problem-p :initform nil
:initarg
:expected-problem-p
694 :reader expected-problem-p
))
695 (:documentation
"A test suite")
697 :run-setup
:once-per-test-case
))
699 (defclass test-result
()
700 ((results-for :initform nil
701 :initarg
:results-for
702 :accessor results-for
)
703 (tests-run :initform nil
:accessor tests-run
)
704 (suites-run :initform nil
:accessor suites-run
)
705 (failures :initform nil
:accessor failures
)
706 (expected-failures :initform nil
:accessor expected-failures
)
707 (errors :initform nil
:accessor errors
)
708 (expected-errors :initform nil
:accessor expected-errors
)
709 (test-mode :initform
:single
:initarg
:test-mode
:accessor test-mode
)
710 (test-interactive?
:initform nil
711 :initarg
:test-interactive?
:accessor test-interactive?
)
712 (real-start-time :initarg
:real-start-time
:reader real-start-time
)
713 (start-time :accessor start-time
:initform nil
)
714 (end-time :accessor end-time
)
715 (real-end-time :accessor real-end-time
)
716 (real-start-time-universal
717 :initarg
:real-start-time-universal
:reader real-start-time-universal
)
718 (start-time-universal :accessor start-time-universal
:initform nil
)
719 (end-time-universal :accessor end-time-universal
)
720 (real-end-time-universal :accessor real-end-time-universal
)
721 (properties :initform nil
:accessor test-result-properties
))
723 :test-interactive?
*test-is-being-defined?
*
724 :real-start-time
(get-internal-real-time)
725 :real-start-time-universal
(get-universal-time)))
727 (defun test-result-property (result property
)
728 (getf (test-result-properties result
) property
))
730 (defun (setf test-result-property
) (value result property
)
731 (setf (getf (test-result-properties result
) property
) value
))
733 (defun print-lift-message (message &rest args
)
734 (apply #'format
*lift-debug-output
* message args
)
735 (force-output *lift-debug-output
*))
737 (defgeneric testsuite-setup
(testsuite result
)
738 (:documentation
"Setup at the testsuite-level")
739 (:method
((testsuite test-mixin
) (result test-result
))
741 (:method
:before
((testsuite test-mixin
) (result test-result
))
742 (when (and *test-print-testsuite-names
*
743 (eq (test-mode result
) :multiple
))
744 (print-lift-message "~&Start: ~a" (type-of testsuite
)))
745 (push (type-of testsuite
) (suites-run result
))
746 (setf (current-step testsuite
) :testsuite-setup
)))
748 (defgeneric testsuite-run
(testsuite result
)
749 (:documentation
"Run the cases in this suite and it's children."))
751 (defgeneric testsuite-teardown
(testsuite result
)
752 (:documentation
"Cleanup at the testsuite level.")
753 (:method
((testsuite test-mixin
) (result test-result
))
756 (:method
:after
((testsuite test-mixin
) (result test-result
))
757 (setf (current-step testsuite
) :testsuite-teardown
758 (real-end-time result
) (get-internal-real-time)
759 (real-end-time-universal result
) (get-universal-time))))
761 (defgeneric more-prototypes-p
(testsuite)
762 (:documentation
"Returns true if another prototype set exists for the case."))
764 (defgeneric initialize-prototypes
(testsuite)
765 (:documentation
"Creates lists of all prototype sets."))
767 (defgeneric next-prototype
(testsuite)
768 (:documentation
"Ensures that the test environment has the values of the next prototype set."))
770 (defgeneric make-single-prototype
(testsuite))
772 (defgeneric setup-test
(testsuite)
773 (:documentation
"Setup for a test-case. By default it does nothing."))
775 (defgeneric teardown-test
(testsuite)
776 (:documentation
"Tear-down a test-case. By default it does nothing.")
777 (:method-combination progn
:most-specific-first
))
779 (defgeneric testsuite-methods
(testsuite)
780 (:documentation
"Returns a list of the test methods defined for test. I.e.,
781 the methods that should be run to do the tests for this test."))
783 (defgeneric lift-test
(suite name
)
786 (defgeneric do-testing
(testsuite result fn
)
789 (defgeneric end-test
(result case method-name
)
792 (defgeneric initialize-test
(test)
795 (defgeneric run-test-internal
(case name result
)
798 (defgeneric run-tests-internal
(case &key result
)
801 (defgeneric start-test
(result case method-name
)
804 (defgeneric test-report-code
(testsuite method
)
807 (defgeneric testsuite-p
(thing)
808 (: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."))
810 (defgeneric testsuite-name-
>gf
(case name
)
813 (defgeneric testsuite-name-
>method
(class name
)
816 (defmethod setup-test :before
((test test-mixin
))
817 (setf *test-scratchpad
* nil
818 (current-step test
) :test-setup
))
820 (defmethod setup-test ((test test-mixin
))
823 (defmethod teardown-test progn
((test test-mixin
))
826 (defmethod teardown-test :around
((test test-mixin
))
827 (setf (current-step test
) :test-teardown
)
830 (defmethod initialize-test ((test test-mixin
))
833 (defmethod initialize-test :before
((test test-mixin
))
835 (initialize-prototypes test
)
836 (next-prototype test
))
838 (defmethod initialize-instance :after
((testsuite test-mixin
) &key
)
839 (when (null (testsuite-name testsuite
))
840 (setf (slot-value testsuite
'name
)
841 (symbol-name (type-of testsuite
)))))
843 (defmethod print-object ((tc test-mixin
) stream
)
844 (print-unreadable-object (tc stream
:identity t
:type t
)
845 (format stream
"~a" (testsuite-name tc
))))
847 ;;; ---------------------------------------------------------------------------
849 ;;; ---------------------------------------------------------------------------
851 (defvar *current-definition
* nil
852 "An associative-container which saves interesting information about
853 the thing being defined.")
855 (defun initialize-current-definition ()
856 (setf *current-definition
* nil
))
858 (defun set-definition (name value
)
859 (let ((current (assoc name
*current-definition
*)))
861 (setf (cdr current
) value
)
862 (push (cons name value
) *current-definition
*)))
865 (defun def (name &optional
(definition *current-definition
*))
866 (when definition
(cdr (assoc name definition
))))
868 (defun (setf def
) (value name
)
869 (set-definition name value
))
871 (defvar *code-blocks
* nil
)
873 (defstruct (code-block (:type list
) (:conc-name nil
))
874 block-name
(priority 0) filter code operate-when
)
876 (defgeneric block-handler
(name value
)
878 (:method
((name t
) (value t
))
879 (error "Unknown clause: ~A" name
)))
881 (defun add-code-block (name priority operate-when filter handler code
)
882 (let ((current (assoc name
*code-blocks
*))
883 (value (make-code-block
884 :operate-when operate-when
890 (setf (cdr current
) value
)
891 (push (cons name value
) *code-blocks
*))
893 `(defmethod block-handler ((name (eql ',name
)) value
)
894 (declare (ignorable value
))
896 (setf *code-blocks
* (sort *code-blocks
* #'<
897 :key
(lambda (name.cb
)
898 (priority (cdr name.cb
))))))
900 (defmacro with-test-slots
(&body body
)
901 `(symbol-macrolet ((lift-result (getf (test-data *current-test
*) :result
)))
903 ,(mapcar #'(lambda (local)
904 `(,local
(test-environment-value ',local
)))
907 ,(mapcar (lambda (spec)
908 (destructuring-bind (name arglist
) spec
911 *current-test
* ',',name
,,@arglist
))))
912 (def :function-specs
))
915 (defvar *deftest-clauses
*
916 '(:setup
:teardown
:test
:documentation
:tests
:export-p
:export-slots
917 :run-setup
:dynamic-variables
:equality-test
:categories
:function
))
919 (defmacro deftest
(testsuite-name superclasses slots
&rest
921 "The `deftest` form is obsolete, see [deftestsuite][]."
923 (warn "Deftest is obsolete, use deftestsuite instead.")
924 `(deftestsuite ,testsuite-name
,superclasses
,slots
,@clauses-and-options
))
926 (setf *code-blocks
* nil
)
930 (lambda () (or (def :setup
) (def :direct-slot-names
)))
931 '((setf (def :setup
) (cleanup-parsed-parameter value
)))
932 'build-setup-test-method
)
935 :teardown
100 :methods
936 (lambda () (or (def :teardown
) (def :direct-slot-names
)))
937 '((setf (def :teardown
) (cleanup-parsed-parameter value
)))
938 'build-test-teardown-method
)
942 (lambda () (def :functions
))
943 '((push value
(def :functions
)))
944 'build-test-local-functions
)
947 :documentation
0 :class-def
949 '((setf (def :documentation
) (first value
)))
953 :export-p
0 :class-def
955 '((setf (def :export-p
) (first value
)))
959 :export-slots
0 :class-def
961 '((setf (def :export-slots
) (first value
)))
965 :run-setup
0 :class-def
967 '((push (first value
) (def :default-initargs
))
968 (push :run-setup
(def :default-initargs
))
969 (setf (def :run-setup
) (first value
)))
973 :equality-test
0 :class-def
975 '((push (first value
) (def :default-initargs
))
976 (push :equality-test
(def :default-initargs
)))
980 :log-file
0 :class-def
982 '((push (first value
) (def :default-initargs
))
983 (push :log-file
(def :default-initargs
)))
987 :dynamic-variables
0 :class-def
989 '((setf (def :direct-dynamic-variables
) value
))
993 :categories
0 :class-def
995 '((push value
(def :categories
)))
998 (defmacro deftestsuite
(testsuite-name superclasses slots
&rest
1001 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.
1003 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.
1005 Slots are specified as in defclass with the following additions:
1007 * 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)`.
1008 * 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
1010 (deftestsuite my-test ()
1013 then `my-slot` will be initialized to 23 during test setup.
1015 Test options are one of :setup, :teardown, :test, :tests, :documentation, :export-p, :dynamic-variables, :export-slots, :function, :categories, :run-setup, or :equality-test.
1017 * :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.
1019 * :documentation - a string specifying any documentation for the test. Should only be specified once.
1021 * :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.
1023 * :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.
1025 * :export-p - If true, the testsuite name will be exported from the current package. Should only be specified once.
1027 * :export-slots - if true, any slots specified in the test suite will be exported from the current package. Should only be specified once.
1029 * :function - creates a locally accessible function for this test suite. May be specified multiple times.
1031 * :run-setup - specify when to run the setup code for this test suite. Allowed values are
1033 * :once-per-test-case or t (the default)
1038 :run-setup is handy when a testsuite has a time consuming setup phase that you do not want to repeat for every test.
1040 * :setup - a list of forms to be evaluated before each test case is run. Should only be specified once.
1042 * :teardown - a list of forms to be evaluated after each test case is run. Should only be specified once.
1044 * :test - Define a single test case. Can be specified multiple times.
1046 * :tests - Define multiple test cases for this test suite. Can be specified multiple times.
1051 (let ((test-list nil
)
1054 ;; convert any clause like :setup foo into (:setup foo)
1055 (setf clauses-and-options
1056 (convert-clauses-into-lists clauses-and-options
*deftest-clauses
*))
1057 (initialize-current-definition)
1058 (setf (def :testsuite-name
) testsuite-name
)
1059 (setf (def :superclasses
) (mapcar #'find-testsuite superclasses
))
1060 (setf (def :deftestsuite
) t
)
1061 ;; parse clauses into defs
1062 (loop for clause in clauses-and-options do
1064 (symbol (pushnew clause options
))
1065 (cons (destructuring-bind (kind &rest spec
) clause
1067 (:test
(push (first spec
) test-list
))
1069 (loop for test in spec do
1070 (push test test-list
)))
1071 (t (block-handler kind spec
)))))
1072 (t (error "When parsing ~S" clause
))))
1073 (let ((slot-names nil
) (slot-specs nil
))
1074 (loop for slot in
(if (listp slots
) slots
(list slots
)) do
1075 (push (if (consp slot
) (first slot
) slot
) slot-names
)
1076 (push (parse-brief-slot slot nil nil nil nil
) slot-specs
))
1077 (setf (def :slot-specs
) (nreverse slot-specs
)
1078 (def :direct-slot-names
) (nreverse slot-names
)
1079 (def :slots-parsed
) t
))
1080 ;;?? issue 27: breaks 'encapsulation' of code-block mechanism
1081 (setf (def :function-specs
)
1082 (loop for spec in
(def :functions
) collect
1083 (destructuring-bind (name arglist
&body body
) (first spec
)
1084 (declare (ignore body
))
1085 `(,name
,arglist
))))
1087 (empty-test-tables testsuite-name
)
1088 (compute-superclass-inheritence)
1090 (setf *testsuite-test-count
* 0)
1091 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
1092 (eval-when (:compile-toplevel
)
1093 (push ',return
*test-is-being-compiled?
*))
1094 (eval-when (:load-toplevel
)
1095 (push ',return
*test-is-being-loaded?
*))
1096 (eval-when (:execute
)
1097 (push ',return
*test-is-being-executed?
*))
1098 ;; remove previous methods (do this _before_ we define the class)
1099 (remove-previous-definitions ',(def :testsuite-name
))
1102 (let ((*test-is-being-defined?
* t
))
1103 (setf *current-case-method-name
* nil
)
1104 (setf *current-suite-class-name
* ',(def :testsuite-name
)
1105 (test-slots ',(def :testsuite-name
))
1107 (testsuite-dynamic-variables ',(def :testsuite-name
))
1108 ',(def :dynamic-variables
)
1109 ;;?? issue 27: breaks 'encapsulation' of code-block mechanism
1110 (testsuite-function-specs ',(def :testsuite-name
))
1111 ',(def :function-specs
))
1112 ,@(when (def :export-p
)
1113 `((export '(,(def :testsuite-name
)))))
1114 ,@(when (def :export-slots?
)
1115 `((export ',(def :direct-slot-names
))))
1116 ;; make a place to save test-case information
1117 (empty-test-tables ',(def :testsuite-name
))
1120 ,@(build-initialize-test-method)
1121 ,@(loop for
(nil . block
) in
*code-blocks
*
1124 (eq (operate-when block
) :methods
)
1125 (or (not (filter block
))
1126 (funcall (filter block
)))) collect
1127 (funcall (code block
)))
1128 ,@(when (def :dynamic-variables
)
1129 `((defmethod do-testing :around
1130 ((suite ,(def :testsuite-name
)) result fn
)
1131 (declare (ignore result fn
))
1132 (cond ((done-dynamics? suite
)
1135 (setf (slot-value suite
'done-dynamics?
) t
)
1136 (let* (,@(build-dynamics))
1137 (call-next-method)))))))
1140 `((let ((*test-evaluate-when-defined?
* nil
))
1141 ,@(loop for test in
(nreverse test-list
) collect
1142 `(addtest (,(def :testsuite-name
))
1144 (setf *testsuite-test-count
* nil
))))
1145 ,(if *test-evaluate-when-defined?
*
1146 `(unless (or *test-is-being-compiled?
*
1147 *test-is-being-loaded?
*)
1148 (let ((*test-break-on-errors?
* *test-break-on-errors?
*))
1149 (run-tests :suite
',testsuite-name
)))
1150 `(find-class ',testsuite-name
)))
1152 (setf *test-is-being-compiled?
*
1153 (remove ',return
*test-is-being-compiled?
*))
1154 (setf *test-is-being-loaded?
*
1155 (remove ',return
*test-is-being-loaded?
*))
1156 (setf *test-is-being-executed?
*
1157 (remove ',return
*test-is-being-executed?
*)))))))
1159 (defun compute-superclass-inheritence ()
1160 ;;?? issue 27: break encapsulation of code blocks
1161 ;;?? we assume that we won't have too deep a hierarchy or too many
1162 ;; dv's or functions so that having lots of duplicate names is OK
1164 (dynamic-variables nil
)
1165 (function-specs nil
))
1166 (dolist (super (def :superclasses
))
1167 (cond ((find-testsuite super
)
1168 (setf slots
(append slots
(test-slots super
))
1170 (append dynamic-variables
1171 (testsuite-dynamic-variables super
))
1173 (append function-specs
1174 (testsuite-function-specs super
))))
1176 (error 'test-class-not-defined
:test-class-name super
))))
1177 (setf (def :slot-names
)
1178 (remove-duplicates (append (def :direct-slot-names
) slots
))
1179 (def :dynamic-variables
)
1181 (append (def :direct-dynamic-variables
) dynamic-variables
))
1182 (def :function-specs
)
1184 (append (def :function-specs
) function-specs
)))
1185 (setf (def :superclasses
)
1186 (loop for class in
(def :superclasses
)
1187 unless
(some (lambda (oter)
1188 (and (not (eq class oter
))
1189 (member class
(superclasses oter
))))
1190 (def :superclasses
)) collect
1193 (defmacro addtest
(name &body test
)
1194 "Adds a single new test-case to the most recently defined testsuite."
1201 (looks-like-suite-name (looks-like-suite-name-p name
))
1202 (looks-like-code (looks-like-code-p name
)))
1203 (cond ((and looks-like-suite-name looks-like-code
)
1204 (error "Can't disambiguate suite name from possible code."))
1205 (looks-like-suite-name
1207 (setf (def :testsuite-name
) (first name
)
1209 name nil body test
))
1211 ;; the 'name' is really part of the test...
1212 (setf body
(cons name test
))))
1213 (unless (def :testsuite-name
)
1214 (when *current-suite-class-name
*
1215 (setf (def :testsuite-name
) *current-suite-class-name
*)))
1216 (unless (def :testsuite-name
)
1217 (signal-lift-error 'add-test
+lift-no-current-test-class
+))
1218 (unless (or (def :deftestsuite
)
1219 (find-testsuite (def :testsuite-name
)))
1220 (signal-lift-error 'add-test
+lift-test-class-not-found
+
1221 (def :testsuite-name
)))
1222 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
1223 (eval-when (:compile-toplevel
)
1224 (push ',return
*test-is-being-compiled?
*))
1225 (eval-when (:load-toplevel
)
1226 (push ',return
*test-is-being-loaded?
*))
1227 (eval-when (:execute
)
1228 (push ',return
*test-is-being-executed?
*))
1230 (let ((*test-is-being-defined?
* t
))
1231 ,(build-test-test-method (def :testsuite-name
) body options
)
1232 (setf *current-suite-class-name
* ',(def :testsuite-name
))
1233 (if *test-evaluate-when-defined?
*
1234 (unless (or *test-is-being-compiled?
*
1235 *test-is-being-loaded?
*)
1236 (let ((*test-break-on-errors?
* (testing-interactively-p)))
1240 (setf *test-is-being-compiled?
*
1241 (remove ',return
*test-is-being-compiled?
*)
1242 *test-is-being-loaded?
*
1243 (remove ',return
*test-is-being-loaded?
*)
1244 *test-is-being-executed?
*
1245 (remove ',return
*test-is-being-executed?
*))))))
1247 (defun looks-like-suite-name-p (form)
1250 (find-testsuite (first form
))
1251 (property-list-p (rest form
))))
1253 (defun property-list-p (form)
1258 for want-keyword?
= t then
(not want-keyword?
) do
1259 (when (and want-keyword?
(not (keywordp x
)))
1260 (return-from check-it nil
))
1261 (setf even?
(not even?
)))
1262 (return-from check-it even?
)))))
1265 (property-list-p '(:a
:b
))
1266 (property-list-p '(:a
2 :b
3 :c
5 :d
8))
1267 (property-list-p nil
)
1270 (property-list-p '(3))
1271 (property-list-p '(3 :a
))
1272 (property-list-p '(:a
3 :b
))
1275 (defun looks-like-code-p (name)
1276 (declare (ignore name
))
1280 (defun remove-test (&key
(name *current-case-method-name
*)
1281 (suite *current-suite-class-name
*))
1282 (assert suite nil
"Test suite could not be determined.")
1283 (assert name nil
"Test name could not be determined.")
1284 (setf (testsuite-tests suite
)
1285 (remove name
(testsuite-tests suite
))))
1287 (defun run-test (&rest args
1288 &key
(name *current-case-method-name
*)
1289 (suite *current-suite-class-name
*)
1290 (break-on-errors?
*test-break-on-errors?
*)
1291 (do-children?
*test-do-children?
*)
1293 (assert suite nil
"Test suite could not be determined.")
1294 (assert name nil
"Test name could not be determined.")
1295 (let* ((*test-break-on-errors?
* break-on-errors?
)
1296 (*test-do-children?
* do-children?
)
1297 (*current-test
* (make-testsuite suite args
)))
1299 (setf result
(make-test-result suite
:single
)))
1300 (setf *current-case-method-name
* name
1301 *current-suite-class-name
* suite
)
1302 (do-testing *current-test
* result
1304 (run-test-internal *current-test
* name result
)))))
1306 (defun make-testsuite (suite args
)
1307 (let ((make-instance-args nil
))
1308 (loop for keyword in
*make-testsuite-arguments
* do
1309 (when (member keyword args
)
1310 (push keyword make-instance-args
)
1311 (push (getf args keyword
) make-instance-args
)))
1312 (apply #'make-instance
(find-testsuite suite
) make-instance-args
)))
1314 (defmethod do-testing ((testsuite test-mixin
) result fn
)
1317 (testsuite-setup testsuite result
)
1318 (let ((*lift-equality-test
* (equality-test testsuite
)))
1320 ((not (more-prototypes-p testsuite
)) result
)
1321 (initialize-test testsuite
)
1324 (testsuite-teardown testsuite result
))
1327 (defmethod run-tests-internal ((suite symbol
) &rest args
&key
&allow-other-keys
)
1328 (let ((*current-test
* (make-testsuite suite args
)))
1329 (apply #'run-tests-internal
1333 (defmethod run-tests-internal
1334 ((case test-mixin
) &key
1335 (result (make-test-result (class-of case
) :multiple
))
1336 (do-children?
*test-do-children?
*))
1337 (let ((*test-do-children?
* do-children?
))
1338 (do-testing case result
1340 (testsuite-run case result
)))
1341 (setf *test-result
* result
)))
1344 (defmacro with-test
(&body forms
)
1345 "Execute forms in the context of the current test class."
1346 (let* ((test-class-name *current-suite-class-name
*)
1347 (test-case (make-instance test-class
)))
1348 `(eval-when (:execute
)
1350 (setup-test ,test-case
)
1352 (with-test-slots ,@forms
))
1353 (teardown-test ,test-case
)))))
1355 (defun map-testsuites (fn start-at
)
1356 (let ((visited (make-hash-table)))
1357 (labels ((do-it (suite level
)
1358 (unless (gethash suite visited
)
1359 (setf (gethash suite visited
) t
)
1360 (funcall fn suite level
)
1361 (loop for subclass in
(subclasses suite
:proper? t
) do
1362 (do-it subclass
(1+ level
))))))
1363 (do-it (find-class (find-testsuite start-at
) nil
) 0))))
1365 (defun testsuites (&optional
(start-at 'test-mixin
))
1366 "Returns a list of testsuite classes. The optional parameter provides
1367 control over where in the test hierarchy the search begins."
1369 (map-testsuites (lambda (suite level
)
1370 (declare (ignore level
))
1371 (push suite result
))
1375 (defun print-tests (&key
(include-cases? t
) (start-at 'test-mixin
) (stream t
))
1376 "Prints all of the defined test classes from :start-at on down."
1378 (lambda (suite level
)
1379 (let ((indent (coerce (make-list (* level
3) :initial-element
#\Space
)
1381 (name (class-name suite
)))
1382 (format stream
"~&~a~s (~:d)"
1385 (length (testsuite-methods name
)))
1386 (when include-cases?
1387 (loop for method-name in
(testsuite-tests name
) do
1388 (format stream
"~&~a ~a" indent method-name
)))))
1391 (defun list-tests (&key
(include-cases? t
) (start-at 'test-mixin
) (stream t
))
1392 "Lists all of the defined test classes from :start-at on down."
1393 (mapc (lambda (subclass-name)
1394 (format stream
"~&~s (~:d)"
1396 (length (testsuite-methods subclass-name
)))
1397 (when include-cases?
1398 (loop for method-name in
(testsuite-tests subclass-name
) do
1399 (format stream
"~& ~a" method-name
))))
1400 (testsuites start-at
))
1403 (defun testsuite-test-count (testsuite)
1404 (or (and *testsuite-test-count
*
1405 (prog1 *testsuite-test-count
* (incf *testsuite-test-count
*)))
1406 (length (testsuite-methods testsuite
))))
1408 (defun run-tests (&rest args
&key
1410 (break-on-errors?
*test-break-on-errors?
*)
1412 (dribble *lift-dribble-pathname
*)
1413 (result (make-test-result (or suite config
) :multiple
))
1416 "Run all of the tests in a suite. Arguments are :suite, :result, :do-children? and :break-on-errors?"
1418 (remf args
:break-on-errors?
)
1419 (remf args
:run-setup
)
1420 (remf args
:dribble
)
1421 (cond ((and suite config
)
1422 (error "Specify either configuration file or test suite but not both."))
1424 (run-tests-from-file config
))
1425 ((or suite
(setf suite
*current-suite-class-name
*))
1426 (let* ((*test-break-on-errors?
* break-on-errors?
)
1431 :if-does-not-exist
:create
1432 :if-exists
*lift-if-dribble-exists
*)))
1433 (*standard-output
* (maybe-add-dribble
1434 *lift-standard-output
* dribble-stream
))
1435 (*error-output
* (maybe-add-dribble
1436 *error-output
* dribble-stream
))
1437 (*debug-io
* (maybe-add-dribble
1438 *debug-io
* dribble-stream
)))
1440 (dolist (name (if (consp suite
) suite
(list suite
)))
1441 (setf *current-suite-class-name
* name
)
1442 (apply #'run-tests-internal name
:result result args
))
1444 (when dribble-stream
1445 (close dribble-stream
)))
1447 (setf (tests-run result
) (reverse (tests-run result
)))
1450 (error "There is not a current test suite and neither suite nor configuration file options were specified."))))
1452 (defun maybe-add-dribble (stream dribble-stream
)
1454 (values (make-broadcast-stream stream dribble-stream
) t
)
1455 (values stream nil
)))
1457 (defmethod testsuite-run ((case test-mixin
) (result test-result
))
1458 (unless (start-time result
)
1459 (setf (start-time result
) (get-internal-real-time)
1460 (start-time-universal result
) (get-universal-time)))
1462 (let ((methods (testsuite-methods case
)))
1463 (loop for method in methods do
1464 (run-test-internal case method result
))
1465 (when *test-do-children?
*
1466 (loop for subclass in
(direct-subclasses (class-of case
))
1467 when
(and (testsuite-p subclass
)
1468 (not (member (class-name subclass
)
1469 (suites-run result
)))) do
1470 (run-tests-internal (class-name subclass
)
1472 (setf (end-time result
) (get-universal-time))))
1474 (defmethod more-prototypes-p ((testsuite test-mixin
))
1475 (not (null (prototypes testsuite
))))
1477 (defmethod initialize-prototypes ((testsuite test-mixin
))
1478 (setf (prototypes testsuite
)
1479 (list (make-single-prototype testsuite
))))
1481 (defmethod make-single-prototype ((testsuite test-mixin
))
1484 (defmethod initialize-prototypes :around
((suite test-mixin
))
1485 (unless (prototypes-initialized? suite
)
1486 (setf (slot-value suite
'prototypes-initialized?
) t
)
1487 (call-next-method)))
1489 (defmethod next-prototype ((testsuite test-mixin
))
1490 (setf (current-values testsuite
) (first (prototypes testsuite
))
1491 (prototypes testsuite
) (rest (prototypes testsuite
)))
1492 (dolist (key.value
(current-values testsuite
))
1493 (setf (test-environment-value (car key.value
)) (cdr key.value
))))
1495 (defmethod run-test-internal ((case test-mixin
) (name symbol
) result
)
1496 (when (and *test-print-test-case-names
*
1497 (eq (test-mode result
) :multiple
))
1498 (print-lift-message "~& run: ~a" name
))
1499 (let ((problem nil
))
1501 (declare (ignorable problem
))
1505 (handler-bind ((warning #'muffle-warning
)
1506 ; ignore warnings...
1510 (report-test-problem
1511 'test-error result case name cond
1512 :backtrace
(get-backtrace cond
)))
1513 (if *test-break-on-errors?
*
1514 (invoke-debugger cond
)
1517 ;; FIXME - too much! should we catch serious-conditions?
1520 (report-test-problem
1521 'test-error result case name cond
1522 :backtrace
(get-backtrace cond
))))))
1524 (current-method case
) name
)
1525 (start-test result case name
)
1529 (declare (ignorable result
))
1530 (setf (current-step case
) :testing
1533 (getf (test-data case
) :seconds
)
1534 (getf (test-data case
) :conses
)
1535 (lift-test case name
)))
1536 (check-for-surprises result case name
))
1537 (teardown-test case
)
1538 (end-test result case name
)))
1539 (ensure-failed (cond)
1541 (report-test-problem
1542 'test-failure result case name cond
)))
1543 (retry-test () :report
"Retry the test."
1546 (setf (third (first (tests-run result
))) (test-data case
))
1547 (setf *test-result
* result
))
1549 (define-condition unexpected-success-failure
(test-condition)
1550 ((expected :reader expected
:initarg
:expected
)
1551 (expected-more :reader expected-more
:initarg
:expected-more
))
1552 (:report
(lambda (c s
)
1553 (format s
"Test succeeded but we expected ~s (~s)"
1555 (expected-more c
)))))
1557 (defun check-for-surprises (results testsuite name
)
1558 (declare (ignore results name
))
1559 (let* ((options (getf (test-data testsuite
) :options
))
1560 (expected-failure-p (second (member :expected-failure options
)))
1561 (expected-error-p (second (member :expected-error options
)))
1562 (expected-problem-p (second (member :expected-problem options
)))
1566 (setf (slot-value testsuite
'expected-failure-p
) expected-failure-p
))
1568 (setf (slot-value testsuite
'expected-error-p
) expected-error-p
))
1570 (setf (slot-value testsuite
'expected-problem-p
) expected-problem-p
)))
1572 ((expected-failure-p testsuite
)
1574 (make-condition 'unexpected-success-failure
1576 :expected-more
(expected-failure-p testsuite
))))
1577 ((expected-error-p testsuite
)
1579 (make-condition 'unexpected-success-failure
1581 :expected-more
(expected-error-p testsuite
))))
1582 ((expected-problem-p testsuite
)
1584 (make-condition 'unexpected-success-failure
1586 :expected-more
(expected-problem-p testsuite
)))))
1588 (if (find-restart 'ensure-failed
)
1589 (invoke-restart 'ensure-failed condition
)
1590 (warn condition
)))))
1592 (defun report-test-problem (problem-type result suite method condition
1596 (options (getf (test-data suite
) :options
))
1598 (declare (ignore docs option
))
1599 (cond ((and (eq problem-type
'test-failure
)
1600 (not (typep condition
'unexpected-success-failure
))
1601 (member :expected-failure options
))
1602 (setf problem-type
'test-expected-failure
1603 option
:expected-failure
))
1604 ((and (eq problem-type
'test-error
)
1605 (member :expected-error
(getf (test-data suite
) :options
)))
1606 (setf problem-type
'test-expected-error
1607 option
:expected-error
))
1608 ((and (or (eq problem-type
'test-failure
)
1609 (eq problem-type
'test-error
))
1610 (member :expected-problem
(getf (test-data suite
) :options
)))
1611 (setf problem-type
(or (and (eq problem-type
'test-failure
)
1612 'test-expected-failure
)
1613 (and (eq problem-type
'test-error
)
1614 'test-expected-error
))
1615 option
:expected-problem
)))
1616 (let ((problem (apply #'make-instance problem-type
1619 :test-condition condition
1620 :test-step
(current-step suite
) args
)))
1621 (setf (getf (test-data suite
) :problem
) problem
)
1623 (test-failure (push problem
(failures result
)))
1624 (test-expected-failure (push problem
(expected-failures result
)))
1625 (test-error (push problem
(errors result
)))
1626 (test-expected-error (push problem
(expected-errors result
))))
1629 ;;; ---------------------------------------------------------------------------
1630 ;;; test-result and printing
1631 ;;; ---------------------------------------------------------------------------
1633 (defun get-test-print-length ()
1634 (let ((foo *test-print-length
*))
1635 (if (eq foo
:follow-print
) *print-length
* foo
)))
1637 (defun get-test-print-level ()
1638 (let ((foo *test-print-level
*))
1639 (if (eq foo
:follow-print
) *print-level
* foo
)))
1641 (defmethod start-test ((result test-result
) (case test-mixin
) name
)
1642 (push (list (type-of case
) name nil
) (tests-run result
))
1643 (setf (current-step case
) :start-test
1645 `(:start-time
,(get-internal-real-time)
1646 :start-time-universal
,(get-universal-time))))
1648 (defmethod end-test ((result test-result
) (testsuite test-mixin
) name
)
1649 (declare (ignore name
))
1650 (setf (current-step testsuite
) :end-test
1651 (getf (test-data testsuite
) :end-time
) (get-internal-real-time)
1652 (end-time result
) (get-internal-real-time)
1653 (getf (test-data testsuite
) :end-time-universal
) (get-universal-time)
1654 (end-time-universal result
) (get-universal-time)))
1656 (defun make-test-result (for test-mode
)
1657 (make-instance 'test-result
1659 :test-mode test-mode
))
1661 (defun testing-interactively-p ()
1664 (defmethod print-object ((tr test-result
) stream
)
1665 (let ((complete-success?
(and (null (errors tr
))
1666 (null (failures tr
))
1667 (null (expected-failures tr
))
1668 (null (expected-errors tr
)))))
1669 (let* ((*print-level
* (get-test-print-level))
1670 (*print-length
* (get-test-print-length)))
1671 (print-unreadable-object (tr stream
)
1672 (cond ((null (tests-run tr
))
1673 (format stream
"~A: no tests defined" (results-for tr
)))
1674 ((eq (test-mode tr
) :single
)
1675 (cond ((test-interactive? tr
)
1677 (cond (complete-success?
1678 (format stream
"Test passed"))
1680 (format stream
"Error during testing"))
1681 ((expected-errors tr
)
1682 (format stream
"Expected error during testing"))
1684 (format stream
"Test failed"))
1686 (format stream
"Test failed expectedly"))))
1689 (format stream
"~A.~A ~A"
1691 (first (first (tests-run tr
)))
1692 (cond (complete-success?
1698 (when (or (expected-errors tr
) (expected-failures tr
))
1699 (format stream
"(~[~:;, ~:*~A expected failure~:P~]~[~:;, ~:*~A expected error~:P~])"
1700 (expected-failures tr
) (expected-errors tr
))))))
1702 ;; multiple tests run
1703 (format stream
"Results for ~A " (results-for tr
))
1704 (if complete-success?
1705 (format stream
"[~A Successful test~:P]"
1706 (length (tests-run tr
)))
1707 (format stream
"~A Test~:P~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Error~:P~]~[~:;, ~:*~A Expected failure~:P~]~[~:;, ~:*~A Expected error~:P~]"
1708 (length (tests-run tr
))
1709 (length (failures tr
))
1710 (length (errors tr
))
1711 (length (expected-failures tr
))
1712 (length (expected-errors tr
))))))
1713 ;; note that suites with no tests think that they are completely
1714 ;; successful. Optimistic little buggers, huh?
1715 (when (and (not complete-success?
) *test-describe-if-not-successful?
*)
1716 (format stream
"~%")
1717 (print-test-result-details stream tr
))))))
1719 (defmethod describe-object ((result test-result
) stream
)
1720 (let ((number-of-failures (length (failures result
)))
1721 (number-of-expected-failures (length (expected-failures result
)))
1722 (number-of-errors (length (errors result
)))
1723 (number-of-expected-errors (length (expected-errors result
))))
1724 (unless *test-is-being-defined?
*
1725 (format stream
"~&Test Report for ~A: ~D test~:P run"
1726 (results-for result
) (length (tests-run result
))))
1727 (let* ((*print-level
* (get-test-print-level))
1728 (*print-length
* (get-test-print-length)))
1729 (cond ((or (failures result
) (errors result
)
1730 (expected-failures result
) (expected-errors result
))
1731 (format stream
"~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Expected failure~:P~]~[~:;, ~:*~A Error~:P~]~[~:;, ~:*~A Expected error~:P~]."
1733 number-of-expected-failures
1735 number-of-expected-errors
)
1736 (format stream
"~%~%")
1737 (print-test-result-details stream result
))
1738 ((or (expected-failures result
) (expected-errors result
))
1739 (format stream
", all passed *~[~:;, ~:*~A Expected failure~:P~]~[~:;, ~:*~A Expected error~:P~])."
1740 number-of-expected-failures
1741 number-of-expected-errors
)
1742 (format stream
"~%~%")
1743 (print-test-result-details stream result
))
1745 (unless *test-is-being-defined?
*
1746 (format stream
", all passed!")))))
1749 (defun print-test-result-details (stream result
)
1750 (loop for report in
(failures result
) do
1751 (print-test-problem "Failure: " report stream
))
1752 (loop for report in
(errors result
) do
1753 (print-test-problem "ERROR : " report stream
))
1754 (loop for report in
(expected-failures result
) do
1755 (print-test-problem "Expected failure: " report stream
))
1756 (loop for report in
(expected-errors result
) do
1757 (print-test-problem "Expected Error : " report stream
)))
1759 (defun print-test-problem (prefix report stream
)
1760 (let* ((suite (testsuite report
))
1761 (method (test-method report
))
1762 (condition (test-condition report
))
1763 (code (test-report-code suite method
))
1764 (testsuite-name method
))
1765 (format stream
"~&~A~(~A : ~A~)" prefix
(type-of suite
) testsuite-name
)
1766 (let ((doc-string (gethash testsuite-name
1767 (test-case-documentation
1768 (class-name (class-of suite
))))))
1770 (format stream
"~&~A" doc-string
)))
1771 (format stream
"~&~< ~@;~
1772 ~@[Condition: ~<~@;~A~:>~]~
1774 ~&~:>" (list (list condition
) code
))))
1777 ;;; ---------------------------------------------------------------------------
1779 ;;; ---------------------------------------------------------------------------
1781 (defclass test-problem-mixin
()
1782 ((testsuite :initform nil
:initarg
:testsuite
:reader testsuite
)
1783 (test-method :initform nil
:initarg
:test-method
:reader test-method
)
1784 (test-condition :initform nil
1785 :initarg
:test-condition
1786 :reader test-condition
)
1787 (test-problem-kind :reader test-problem-kind
:allocation
:class
)
1788 (test-step :initform nil
:initarg
:test-step
:reader test-step
)))
1790 (defmethod print-object ((problem test-problem-mixin
) stream
)
1791 (print-unreadable-object (problem stream
)
1792 (format stream
"TEST-~@:(~A~): ~A in ~A"
1793 (test-problem-kind problem
)
1794 (name (testsuite problem
))
1795 (test-method problem
))))
1797 (defclass generic-problem
(test-problem-mixin)
1798 ((test-problem-kind :initarg
:test-problem-kind
1799 :allocation
:class
)))
1801 (defclass expected-problem-mixin
()
1802 ((documentation :initform nil
1803 :initarg
:documentation
1804 :accessor failure-documentation
)))
1806 (defclass test-expected-failure
(expected-problem-mixin generic-problem
)
1809 :test-problem-kind
"Expected failure"))
1811 (defclass test-failure
(generic-problem)
1814 :test-problem-kind
"failure"))
1816 (defclass test-error-mixin
(generic-problem)
1817 ((backtrace :initform nil
:initarg
:backtrace
:reader backtrace
)))
1819 (defclass test-expected-error
(expected-problem-mixin test-error-mixin
)
1822 :test-problem-kind
"Expected error"))
1824 (defclass test-error
(test-error-mixin)
1827 :test-problem-kind
"Error"))
1829 (defmethod test-report-code ((testsuite test-mixin
) (method symbol
))
1830 (let* ((class-name (class-name (class-of testsuite
))))
1832 (test-name->code-table class-name
))))
1834 ;;; ---------------------------------------------------------------------------
1836 ;;; ---------------------------------------------------------------------------
1838 (defun remove-test-methods (test-name)
1840 (length (testsuite-tests test-name
))
1841 (setf (testsuite-tests test-name
) nil
)))
1843 (defun remove-previous-definitions (classname)
1844 "Remove the methods of this class and all its subclasses."
1845 (let ((classes-removed nil
)
1846 (class (find-class classname nil
))
1849 (loop for subclass in
(subclasses class
:proper? nil
) do
1850 (push subclass classes-removed
)
1852 (remove-test-methods (class-name subclass
)))
1854 ;;?? causing more trouble than it solves...??
1855 (setf (find-class (class-name subclass
)) nil
))
1857 (unless (length-1-list-p classes-removed
)
1859 "~&;;; Removed Test suite ~(~A~) and its subclasses (~{~<~s~>~^, ~})."
1862 (mapcar #'class-name classes-removed
))
1864 (unless (zerop removed-count
)
1866 "~&;;; Removed ~D methods from test suite ~(~A~)~@[ and its subclasses~]."
1867 removed-count classname
1868 (not (length-1-list-p classes-removed
)))))))
1870 (defun build-initialize-test-method ()
1871 (let ((initforms nil
)
1873 (slot-specs (def :slot-specs
)))
1874 (loop for slot in slot-specs do
1875 (when (and (member :initform
(rest slot
))
1876 (not (eq :unbound
(getf (rest slot
) :initform
))))
1877 (push (getf (rest slot
) :initform
) initforms
)
1878 (push (first slot
) slot-names
)))
1879 (setf slot-names
(nreverse slot-names
)
1880 initforms
(nreverse initforms
))
1882 `((defmethod make-single-prototype ((testsuite ,(def :testsuite-name
)))
1885 (when (next-method-p)
1887 (let* (,@(mapcar (lambda (slot-name initform
)
1888 `(,slot-name
,initform
))
1889 slot-names initforms
))
1890 (list ,@(mapcar (lambda (slot-name)
1891 `(cons ',slot-name
,slot-name
))
1892 slot-names
))))))))))
1894 (defun (setf test-environment-value
) (value name
)
1895 (pushnew (cons name value
) *test-environment
* :test
#'equal
)
1898 (defun test-environment-value (name)
1899 (cdr (assoc name
*test-environment
*)))
1901 (defun remove-from-test-environment (name)
1902 (setf *test-environment
*
1903 (remove name
*test-environment
* :key
#'car
)))
1905 (defun build-test-local-functions ()
1908 (lambda (function-spec)
1909 (destructuring-bind (name arglist
&body body
) (first function-spec
)
1910 `(defmethod flet-test-function ((testsuite ,(def :testsuite-name
))
1911 (function-name (eql ',name
))
1915 `(destructuring-bind ,arglist args
1917 `(progn ,@body
))))))
1920 (defun build-test-teardown-method ()
1921 (let ((test-name (def :testsuite-name
))
1922 (slot-names (def :direct-slot-names
))
1923 (teardown (def :teardown
)))
1925 (unless (consp teardown
)
1926 (setf teardown
(list teardown
)))
1927 (when (length-1-list-p teardown
)
1928 (setf teardown
(list teardown
)))
1929 (when (symbolp (first teardown
))
1930 (setf teardown
(list teardown
))))
1931 (let* ((teardown-code `(,@(when teardown
1932 `((with-test-slots ,@teardown
)))))
1933 (test-code `(,@teardown-code
1934 ,@(mapcar (lambda (slot)
1935 `(remove-from-test-environment ',slot
))
1938 ,@(when teardown-code
1939 `((defmethod teardown-test progn
((testsuite ,test-name
))
1940 (when (run-teardown-p testsuite
:test-case
)
1942 ,@(when teardown-code
1943 `((defmethod testsuite-teardown ((testsuite ,test-name
)
1944 (result test-result
))
1945 (when (run-teardown-p testsuite
:testsuite
)
1948 (defun build-setup-test-method ()
1949 (let ((test-name (def :testsuite-name
))
1950 (setup (def :setup
)))
1952 (unless (consp setup
)
1953 (setf setup
(list setup
)))
1954 (when (length-1-list-p setup
)
1955 (setf setup
(list setup
)))
1956 (when (symbolp (first setup
))
1957 (setf setup
(list setup
)))
1958 (let ((code `((with-test-slots ,@setup
))))
1960 (defmethod setup-test :after
((testsuite ,test-name
))
1963 (defmethod setup-test :around
((test test-mixin
))
1964 (when (run-setup-p test
)
1966 (setf (slot-value test
'done-setup?
) t
)))
1968 (defun run-setup-p (testsuite)
1969 (case (run-setup testsuite
)
1970 (:once-per-session
(error "not implemented"))
1971 (:once-per-suite
(not (done-setup? testsuite
)))
1972 ((:once-per-test-case t
) t
)
1974 (t (error "Don't know about ~s for run-setup" (run-setup testsuite
)))))
1976 (defun run-teardown-p (testsuite when
)
1979 (ecase (run-setup testsuite
)
1980 (:once-per-session nil
)
1981 (:once-per-suite nil
)
1982 ((:once-per-test-case t
) t
)
1983 ((:never nil
) nil
)))
1985 (ecase (run-setup testsuite
)
1986 (:once-per-session nil
)
1988 ((:once-per-test-case t
) nil
)
1989 ((:never nil
) nil
)))))
1991 (defun build-test-test-method (test-class test-body options
)
1992 (multiple-value-bind (test-name body documentation name-supplied?
)
1993 (parse-test-body test-body
)
1994 (declare (ignorable name-supplied?
))
1995 (unless (consp (first body
))
1996 (setf body
(list body
)))
1998 (setf (gethash ',test-name
(test-name->code-table
',test-class
)) ',body
1999 (gethash ',body
(test-code->name-table
',test-class
)) ',test-name
)
2000 ,(when documentation
2001 `(setf (gethash ',test-name
(test-case-documentation ',test-class
))
2004 ,@(when name-supplied?
2005 `((ccl:record-source-file
',test-name
'test-case
)))
2006 (unless (find ',test-name
(testsuite-tests ',test-class
))
2007 (setf (testsuite-tests ',test-class
)
2008 (append (testsuite-tests ',test-class
) (list ',test-name
))))
2009 (defmethod lift-test ((testsuite ,test-class
) (case (eql ',test-name
)))
2011 `((setf (getf (test-data testsuite
) :options
) ',options
)))
2012 (with-test-slots ,@body
))
2013 (setf *current-case-method-name
* ',test-name
)
2014 (when (and *test-print-when-defined?
*
2015 (not (or *test-is-being-compiled?
*
2017 (format *debug-io
* "~&;Test Created: ~(~S.~S~)."
2018 ',test-class
',test-name
))
2019 *current-case-method-name
*)))
2021 (defun build-dynamics ()
2023 (dolist (putative-pair (def :dynamic-variables
))
2024 (if (atom putative-pair
)
2025 (push (list putative-pair nil
) result
)
2026 (push putative-pair result
)))
2029 (defun parse-test-body (test-body)
2030 (let ((test-name nil
)
2034 (test-number (1+ (testsuite-test-count *current-suite-class-name
*)))
2035 (name-supplied? nil
))
2036 ;; parse out any documentation
2037 (loop for form in test-body do
2038 (if (and (consp form
)
2039 (keywordp (first form
))
2040 (eq :documentation
(first form
)))
2041 (setf documentation
(second form
))
2042 (push form parsed-body
)))
2043 (setf test-body
(nreverse parsed-body
))
2044 (setf test-name
(first test-body
))
2045 (cond ((symbolp test-name
)
2047 (intern (format nil
"~A" test-name
))
2048 body
(rest test-body
)
2050 ((and (test-code->name-table
*current-suite-class-name
*)
2053 (test-code->name-table
*current-suite-class-name
*))))
2054 (setf body test-body
))
2057 (intern (format nil
"TEST-~A"
2060 (values test-name body documentation name-supplied?
)))
2062 (defun build-test-class ()
2063 ;; for now, we don't generate code from :class-def code-blocks
2064 ;; they are executed only for effect.
2065 (loop for
(nil . block
) in
*code-blocks
*
2068 (eq (operate-when block
) :class-def
)
2069 (or (not (filter block
))
2070 (funcall (filter block
)))) collect
2071 (funcall (code block
)))
2072 (unless (some (lambda (superclass)
2073 (testsuite-p superclass
))
2074 (def :superclasses
))
2075 (pushnew 'test-mixin
(def :superclasses
)))
2076 ;; build basic class and standard class
2077 `(defclass ,(def :testsuite-name
) (,@(def :superclasses
))
2079 ,@(when (def :documentation
)
2080 `((:documentation
,(def :documentation
))))
2082 :test-slot-names
',(def :slot-names
)
2083 ,@(def :default-initargs
))))
2085 (defun parse-test-slots (slot-specs)
2086 (loop for spec in slot-specs collect
2087 (let ((parsed-spec spec
))
2088 (if (member :initform parsed-spec
)
2089 (let ((pos (position :initform parsed-spec
)))
2090 (append (subseq parsed-spec
0 pos
)
2091 (subseq parsed-spec
(+ pos
2))))
2094 (defmethod testsuite-p ((classname symbol
))
2095 (let ((class (find-class classname nil
)))
2098 (typep (allocate-instance class
) 'test-mixin
)
2100 (error (c) (declare (ignore c
)) (values nil
)))))
2102 (defmethod testsuite-p ((object standard-object
))
2103 (testsuite-p (class-name (class-of object
))))
2105 (defmethod testsuite-p ((class standard-class
))
2106 (testsuite-p (class-name class
)))
2108 (defmethod testsuite-methods ((classname symbol
))
2109 (testsuite-tests classname
))
2111 (defmethod testsuite-methods ((test test-mixin
))
2112 (testsuite-methods (class-name (class-of test
))))
2114 (defmethod testsuite-methods ((test standard-class
))
2115 (testsuite-methods (class-name test
)))
2118 ;; some handy properties
2119 (defclass-property test-slots
)
2120 (defclass-property test-code-
>name-table
)
2121 (defclass-property test-name-
>code-table
)
2122 (defclass-property test-case-documentation
)
2123 (defclass-property testsuite-prototype
)
2124 (defclass-property testsuite-tests
)
2125 (defclass-property testsuite-dynamic-variables
)
2127 ;;?? issue 27: break encapsulation of code blocks
2128 (defclass-property testsuite-function-specs
)
2130 (defun empty-test-tables (test-name)
2131 (when (find-class test-name nil
)
2132 (setf (test-code->name-table test-name
)
2133 (make-hash-table :test
#'equal
)
2134 (test-name->code-table test-name
)
2135 (make-hash-table :test
#'equal
)
2136 (test-case-documentation test-name
)
2137 (make-hash-table :test
#'equal
))))
2140 (define-condition timeout-error
(error)
2142 (:report
(lambda (c s
)
2143 (declare (ignore c
))
2144 (format s
"Process timeout"))))
2146 (defmacro with-timeout
((seconds) &body body
)
2148 `(mp:with-timeout
(,seconds
(error 'timeout-error
))
2151 `(mp:with-timeout
(,seconds
) ,@body
)
2154 (sb-ext:with-timeout
,seconds
,@body
)
2155 (sb-ext::timeout
(c)
2156 (cerror "Timeout" 'timeout-error
)))
2157 #+(or digitool openmcl
)
2158 (let ((checker-process (format nil
"Checker ~S" (gensym)))
2159 (waiting-process (format nil
"Waiter ~S" (gensym)))
2162 `(let* ((,result nil
)
2163 (,process
(ccl:process-run-function
2166 (setf ,result
(progn ,@body
))))))
2167 (ccl:process-wait-with-timeout
2169 (* ,seconds
#+openmcl ccl
:*ticks-per-second
* #+digitool
60)
2171 (not (ccl::process-active-p
,process
))))
2172 (when (ccl::process-active-p
,process
)
2173 (ccl:process-kill
,process
)
2174 (cerror "Timeout" 'timeout-error
))
2176 #-
(or allegro cmu sb-thread openmcl digitool
)
2179 (defvar *test-maximum-time
* 2
2180 "Maximum number of seconds a process test is allowed to run before we give up.")
2182 (pushnew :timeout
*deftest-clauses
*)
2185 :timeout
1 :class-def
2186 (lambda () (def :timeout
))
2187 '((setf (def :timeout
) (cleanup-parsed-parameter value
)))
2189 (unless (some (lambda (super)
2190 (member (find-class 'process-test-mixin
)
2191 (superclasses super
)))
2192 (def :superclasses
))
2193 (pushnew 'process-test-mixin
(def :superclasses
)))
2194 (push (def :timeout
) (def :default-initargs
))
2195 (push :maximum-time
(def :default-initargs
))
2198 (defclass process-test-mixin
()
2199 ((maximum-time :initform
*test-maximum-time
*
2200 :accessor maximum-time
2201 :initarg
:maximum-time
)))
2203 (defclass test-timeout-failure
(test-failure)
2204 ((test-problem-kind :initform
"Timeout" :allocation
:class
)))
2206 (define-condition test-timeout-condition
(test-condition)
2207 ((maximum-time :initform
*test-maximum-time
*
2208 :accessor maximum-time
2209 :initarg
:maximum-time
))
2210 (:report
(lambda (c s
)
2211 (format s
"Test ran out of time (longer than ~S-second~:P)"
2212 (maximum-time c
)))))
2214 (defmethod do-testing :around
((testsuite process-test-mixin
) result fn
)
2215 (declare (ignore fn
))
2217 (with-timeout ((maximum-time testsuite
))
2221 (declare (ignore c
))
2222 (report-test-problem
2223 'test-timeout-failure result testsuite
(current-method testsuite
)
2224 (make-instance 'test-timeout-condition
2225 :maximum-time
(maximum-time testsuite
))))))
2229 (defmethod find-testsuite ((suite symbol
))
2230 (or (testsuite-p suite
)
2231 (find-testsuite (symbol-name suite
))))
2233 (defmethod find-testsuite ((suite-name string
))
2235 (possibilities (remove-duplicates
2236 (loop for p in
(list-all-packages)
2237 when
(and (setf temp
(find-symbol suite-name p
))
2238 (find-class temp nil
)
2239 (subtypep temp
'test-mixin
)) collect
2241 (cond ((null possibilities
)
2242 (error 'test-class-not-defined
:test-class-name suite-name
))
2243 ((= (length possibilities
) 1)
2244 (first possibilities
))
2246 (error "There are several test suites named ~s: they are ~{~s~^, ~}"
2247 suite-name possibilities
)))))
2249 (defun last-test-status ()
2250 (cond ((typep *test-result
* 'test-result
)
2251 (cond ((and (null (errors *test-result
*))
2252 (null (failures *test-result
*)))
2254 ((and (errors *test-result
*)
2255 (failures *test-result
*))
2256 :errors-and-failures
)
2257 ((errors *test-result
*)
2259 ((failures *test-result
*)
2264 (defun suite-tested-p (suite &key
(result *test-result
*))
2266 (typep *test-result
* 'test-result
)
2267 (slot-exists-p result
'suites-run
)
2268 (slot-boundp result
'suites-run
)
2269 (consp (suites-run result
))
2270 (find suite
(suites-run result
))))
2272 (defun unique-filename (pathname)
2273 (let ((date-part (date-stamp)))
2279 :name
(format nil
"~a-~a-~d"
2280 (pathname-name pathname
)
2283 (unless (probe-file name
)
2284 (return-from unique-filename name
)))
2285 (error "Unable to find unique pathname for ~a" pathname
)))
2287 (defun date-stamp (&key
(datetime (get-universal-time)) (include-time? nil
))
2288 (multiple-value-bind
2289 (second minute hour day month year day-of-the-week
)
2290 (decode-universal-time datetime
)
2291 (declare (ignore day-of-the-week
))
2292 (let ((date-part (format nil
"~d-~2,'0d-~2,'0d" year month day
))
2293 (time-part (and include-time?
2294 (list (format nil
"-~2,'0d-~2,'0d-~2,'0d"
2295 hour minute second
)))))
2296 (apply 'concatenate
'string date-part time-part
))))
2299 (date-stamp :include-time? t
)
2301 ;;?? might be "cleaner" with a macrolet (cf. lift-result)
2302 (defun lift-property (name)
2303 (when *current-test
*
2304 (getf (getf (test-data *current-test
*) :properties
) name
)))
2307 (setf (getf (getf (third (first (tests-run *test-result
*))) :properties
) :foo
)
2310 (defun (setf lift-property
) (value name
)
2311 (when *current-test
*
2312 (setf (getf (getf (test-data *current-test
*) :properties
) name
) value
)))
