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
319 to an output stream. It defaults to *debug-io**.")
321 (defvar *test-break-on-errors?
* nil
)
322 (defvar *test-do-children?
* t
)
323 (defparameter *test-ignore-warnings?
* nil
324 "If true, LIFT will not cause a test to fail if a warning occurs while
325 the test is running. Note that this may interact oddly with ensure-warning.")
326 (defparameter *test-print-when-defined?
* nil
)
327 (defparameter *test-evaluate-when-defined?
* t
)
328 (defparameter *test-scratchpad
* nil
329 "A place to put things. This is set to nil before every test.")
330 (defparameter *test-notepad
* nil
331 "Another place to put things (set {ref *test-scratchpad*}.")
333 (defparameter *lift-equality-test
* 'equal
334 "The function used in ensure-same to test if two things are equal. If metatilities is loaded, then you might want to use samep.")
336 (defvar *test-describe-if-not-successful?
* nil
337 ;; Was t, but this behavior was extremely annoying since each
338 ;; time a test-restul appears in a stack backtrace it is printed
339 ;; over many unstructured lines.
340 "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.")
342 (defvar *test-print-length
* :follow-print
343 "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*`.")
344 (defvar *test-print-level
* :follow-print
345 "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.")
347 (defvar *test-print-testsuite-names
* t
348 "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*.")
350 (defvar *test-print-test-case-names
* nil
351 "If true, LIFT will print the name of each test-case before it runs. See also: *test-print-testsuite-names*.")
353 (defvar *test-result
* nil
354 "Set to the most recent test result by calls to run-test or run-tests.")
356 (defvar *test-environment
* nil
)
358 (defvar *test-metadata
* (list)
359 "A place for LIFT to put stuff.")
361 (defvar *current-test
* nil
362 "The current testsuite.")
364 (defvar *lift-dribble-pathname
* nil
365 "If bound, then test output from run-tests will be sent to this file in
366 in addition to *lift-standard-output*. It can be set to nil or to a pathname.")
368 (defvar *lift-standard-output
* *standard-output
*
369 "Output from tests will be sent to this stream. If can set to nil or
370 to an output stream. It defaults to *standard-output*.")
372 (defvar *lift-if-dribble-exists
* :append
373 "Specifies what to do to any existing file at *lift-dribble-pathname*. It
374 can be :supersede, :append, or :error.")
376 ;;; ---------------------------------------------------------------------------
377 ;;; Error messages and warnings
378 ;;; ---------------------------------------------------------------------------
380 (defparameter +lift-test-name-not-supplied-with-test-class
+
381 "if you specify a test-class, you must also specify a test-name.")
383 (defparameter +lift-test-class-not-found
+
384 "test class '~S' not found.")
386 (defparameter +lift-confused-about-arguments
+
387 "I'm confused about what you said?!")
389 (defparameter +lift-no-current-test-class
+
390 "There is no current-test-class to use as a default.")
392 (defparameter +lift-could-not-find-test
+
393 "Could not find test: ~S.~S")
395 (defparameter +run-tests-null-test-case
+
396 "There is no current testsuite (possibly because
397 none have been defined yet?). You can specify the
398 testsuite to test by evaluating (run-tests :suite <suitename>).")
400 (defparameter +lift-unable-to-parse-test-name-and-class
+
404 ;;; ---------------------------------------------------------------------------
406 ;;; ---------------------------------------------------------------------------
408 (define-condition lift-compile-error
(error)
411 :initarg
:lift-message
))
412 (:report
(lambda (c s
)
413 (format s
"Compile error: '~S'" (msg c
)))))
415 ;;; ---------------------------------------------------------------------------
417 (define-condition test-class-not-defined
(lift-compile-error)
418 ((test-class-name :reader test-class-name
419 :initarg
:test-class-name
))
420 (:report
(lambda (c s
)
421 (format s
"Test class ~A not defined before it was used."
422 (test-class-name c
)))))
424 ;;; ---------------------------------------------------------------------------
426 (defun build-lift-error-message (context message
&rest args
)
429 (apply #'format nil message args
)))
431 ;;; ---------------------------------------------------------------------------
433 (defun signal-lift-error (context message
&rest args
)
434 (let ((c (make-condition
436 :lift-message
(apply #'build-lift-error-message context message args
))))
440 ;;; ---------------------------------------------------------------------------
442 (defun report-lift-error (context message
&rest args
)
443 (format *debug-io
* "~&~A."
444 (apply #'build-lift-error-message context message args
))
447 ;;; ---------------------------------------------------------------------------
449 (defun lift-report-condition (c)
450 (format *debug-io
* "~&~A." c
))
452 ;;; ---------------------------------------------------------------------------
454 (define-condition test-condition
(warning)
455 ((message :initform
""
458 (:report
(lambda (c s
)
460 (format s
"~%~A" (message c
))))))
462 ;;; ---------------------------------------------------------------------------
464 (define-condition ensure-failed-error
(test-condition)
465 ((assertion :initform
""
467 :initarg
:assertion
))
468 (:report
(lambda (c s
)
469 (format s
"Ensure failed: ~S ~@[(~a)~]"
470 (assertion c
) (message c
)))))
472 ;;; ---------------------------------------------------------------------------
474 (define-condition ensure-null-failed-error
(ensure-failed-error)
478 (:report
(lambda (c s
)
479 (format s
"Ensure null failed: ~S ~@[(~a)~]"
480 (value c
) (message c
)))))
482 ;;; ---------------------------------------------------------------------------
484 (define-condition ensure-expected-condition
(test-condition)
485 ((expected-condition-type
487 :accessor expected-condition-type
488 :initarg
:expected-condition-type
)
491 :accessor the-condition
492 :initarg
:the-condition
))
493 (:report
(lambda (c s
)
494 (format s
"Expected ~A but got ~S"
495 (expected-condition-type c
)
496 (the-condition c
)))))
498 ;;; ---------------------------------------------------------------------------
500 (define-condition ensure-not-same
(test-condition)
501 ((first-value :accessor first-value
502 :initarg
:first-value
)
503 (second-value :accessor second-value
504 :initarg
:second-value
)
507 (:report
(lambda (c s
)
508 (format s
"Ensure-same: ~S is not ~S to ~S~@[ (~a)~]"
509 (first-value c
) (test c
) (second-value c
)
512 ;; hacked list to take arguments in addition to args
513 (defmacro ensure
(predicate &key report arguments
)
514 "If ensure's `predicate` evaluates to false, then it will generate a
515 test failure. You can use the `report` and `arguments` keyword parameters
516 to customize the report generated in test results. For example:
519 :report \"I hope ~a does not = ~a\"
522 will generate a message like
524 Warning: Ensure failed: (= 23 12) (I hope 12 does not = 23)
526 (let ((gpredicate (gensym)))
527 `(let ((,gpredicate
,predicate
))
530 (let ((condition (make-condition
532 :assertion
',predicate
535 (format nil
,report
,@arguments
))))))
536 (if (find-restart 'ensure-failed
)
537 (invoke-restart 'ensure-failed condition
)
538 (warn condition
)))))))
540 (defmacro ensure-null
(predicate &key report arguments
)
541 "If ensure-null's `predicate` evaluates to true, then it will generate a
542 test failure. You can use the `report` and `arguments` keyword parameters
543 to customize the report generated in test results. See [ensure][] for more
546 `(let ((,g
,predicate
))
549 (let ((condition (make-condition 'ensure-null-failed-error
552 `(:message
(format nil
,report
,@arguments
))))))
553 (if (find-restart 'ensure-failed
)
554 (invoke-restart 'ensure-failed condition
)
555 (warn condition
)))))))
557 (defmacro ensure-condition
(condition &body body
)
558 "This macro is used to make sure that body really does produce condition."
559 (setf condition
(remove-leading-quote condition
))
560 (destructuring-bind (condition &key report arguments
)
561 (if (consp condition
) condition
(list condition
))
568 (declare (ignore cond
)) (setf ,g t
))
571 (let ((c (make-condition
572 'ensure-expected-condition
573 :expected-condition-type
',condition
576 `(:message
(format nil
,report
,arguments
))))))
577 (if (find-restart 'ensure-failed
)
578 (invoke-restart 'ensure-failed c
)
581 (if (find-restart 'ensure-failed
)
585 'ensure-expected-condition
586 :expected-condition-type
',condition
589 `(:message
(format nil
,report
,arguments
)))))
590 (warn "Ensure-condition didn't get the condition it expected."))))))))
592 (defmacro ensure-warning
(&body body
)
593 "Ensure-warning evaluates its body. If the body does *not* signal a
594 warning, then ensure-warning will generate a test failure."
595 `(ensure-condition warning
,@body
))
597 (defmacro ensure-error
(&body body
)
598 "Ensure-error evaluates its body. If the body does *not* signal an
599 error, then ensure-error will generate a test failure."
600 `(ensure-condition error
,@body
))
602 (defmacro ensure-same
603 (form values
&key
(test nil test-specified-p
)
604 (report nil
) (arguments nil
))
605 "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"
606 (setf test
(remove-leading-quote test
))
607 (when (and (consp test
)
608 (eq (first test
) 'function
))
609 (setf test
(second test
)))
611 (loop for value in
(multiple-value-list ,form
)
612 for other-value in
(multiple-value-list ,values
) do
613 (unless (funcall ,(if test-specified-p
(list 'quote test
) '*lift-equality-test
*)
615 (maybe-raise-not-same-condition
617 ,(if test-specified-p
(list 'quote test
) '*lift-equality-test
*)
618 ,report
,@arguments
)))
621 (defmacro ensure-different
622 (form values
&key
(test nil test-specified-p
)
623 (report nil
) (arguments nil
))
624 "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"
625 ;; FIXME -- share code with ensure-same
626 (setf test
(remove-leading-quote test
))
627 (when (and (consp test
)
628 (eq (first test
) 'function
))
629 (setf test
(second test
)))
631 (loop for value in
(multiple-value-list ,form
)
632 for other-value in
(multiple-value-list ,values
) do
633 ;; WHEN instead of UNLESS
634 (when (funcall ,(if test-specified-p
636 '*lift-equality-test
*)
638 (maybe-raise-not-same-condition
640 ,(if test-specified-p
642 '*lift-equality-test
*) ,report
,@arguments
)))
645 (defun maybe-raise-not-same-condition (value-1 value-2 test
646 report
&rest arguments
)
647 (let ((condition (make-condition 'ensure-not-same
649 :second-value value-2
651 :message
(when report
653 report arguments
)))))
654 (if (find-restart 'ensure-failed
)
655 (invoke-restart 'ensure-failed condition
)
658 (define-condition ensure-cases-failure
(test-condition)
659 ((total :initarg
:total
:initform
0)
660 (problems :initarg
:problems
:initform nil
))
661 (:report
(lambda (condition stream
)
662 (format stream
"Ensure-cases: ~d out of ~d cases failed. Failing cases are: ~{~% ~{~s (~a)~}~^, ~}"
663 (length (slot-value condition
'problems
))
664 (slot-value condition
'total
)
665 (slot-value condition
'problems
)))))
667 (defmacro ensure-cases
((&rest vars
) (&rest cases
) &body body
)
668 (let ((case (gensym))
671 `(let ((,problems nil
) (,total
0))
672 (loop for
,case in
,cases do
674 (destructuring-bind ,vars
,case
677 (ensure-failed (cond)
678 (push (list ,case cond
) ,problems
)))))
680 (let ((condition (make-condition
681 'ensure-cases-failure
683 :problems
,problems
)))
684 (if (find-restart 'ensure-failed
)
685 (invoke-restart 'ensure-failed condition
)
686 (warn condition
)))))))
689 ;;; ---------------------------------------------------------------------------
691 ;;; ---------------------------------------------------------------------------
693 (defclass test-mixin
()
694 ((name :initform nil
:initarg
:name
:accessor name
:reader testsuite-name
)
695 (run-setup :reader run-setup
:initarg
:run-setup
)
696 (done-setup?
:initform nil
:reader done-setup?
)
697 (done-dynamics?
:initform nil
:reader done-dynamics?
)
698 (prototypes :initform
(list (list)) :accessor prototypes
)
699 (prototypes-initialized?
:initform nil
:reader prototypes-initialized?
)
700 (current-values :initform nil
:accessor current-values
)
701 (test-slot-names :initform nil
:initarg
:test-slot-names
702 :reader test-slot-names
)
703 (current-step :initform
:created
:accessor current-step
)
704 (current-method :initform nil
:accessor current-method
)
705 (save-equality-test :initform nil
:reader save-equality-test
)
706 (equality-test :initform
'equal
:initarg
:equality-test
707 :reader equality-test
)
708 (log-file :initform nil
:initarg
:log-file
:reader log-file
)
709 (test-data :initform nil
:accessor test-data
)
710 (expected-failure-p :initform nil
:initarg
:expected-failure-p
711 :reader expected-failure-p
)
712 (expected-error-p :initform nil
:initarg
:expected-error-p
713 :reader expected-error-p
)
714 (expected-problem-p :initform nil
:initarg
:expected-problem-p
715 :reader expected-problem-p
))
716 (:documentation
"A test suite")
718 :run-setup
:once-per-test-case
))
720 (defclass test-result
()
721 ((results-for :initform nil
722 :initarg
:results-for
723 :accessor results-for
)
724 (tests-run :initform nil
:accessor tests-run
)
725 (suites-run :initform nil
:accessor suites-run
)
726 (failures :initform nil
:accessor failures
)
727 (expected-failures :initform nil
:accessor expected-failures
)
728 (errors :initform nil
:accessor errors
)
729 (expected-errors :initform nil
:accessor expected-errors
)
730 (test-mode :initform
:single
:initarg
:test-mode
:accessor test-mode
)
731 (test-interactive?
:initform nil
732 :initarg
:test-interactive?
:accessor test-interactive?
)
733 (real-start-time :initarg
:real-start-time
:reader real-start-time
)
734 (start-time :accessor start-time
:initform nil
)
735 (end-time :accessor end-time
)
736 (real-end-time :accessor real-end-time
)
737 (real-start-time-universal
738 :initarg
:real-start-time-universal
:reader real-start-time-universal
)
739 (start-time-universal :accessor start-time-universal
:initform nil
)
740 (end-time-universal :accessor end-time-universal
)
741 (real-end-time-universal :accessor real-end-time-universal
)
742 (properties :initform nil
:accessor test-result-properties
))
744 :test-interactive?
*test-is-being-defined?
*
745 :real-start-time
(get-internal-real-time)
746 :real-start-time-universal
(get-universal-time)))
748 (defun test-result-property (result property
)
749 (getf (test-result-properties result
) property
))
751 (defun (setf test-result-property
) (value result property
)
752 (setf (getf (test-result-properties result
) property
) value
))
754 (defun print-lift-message (message &rest args
)
755 (apply #'format
*lift-debug-output
* message args
)
756 (force-output *lift-debug-output
*))
758 (defgeneric testsuite-setup
(testsuite result
)
759 (:documentation
"Setup at the testsuite-level")
760 (:method
((testsuite test-mixin
) (result test-result
))
762 (:method
:before
((testsuite test-mixin
) (result test-result
))
763 (when (and *test-print-testsuite-names
*
764 (eq (test-mode result
) :multiple
))
765 (print-lift-message "~&Start: ~a" (type-of testsuite
)))
766 (push (type-of testsuite
) (suites-run result
))
767 (setf (current-step testsuite
) :testsuite-setup
)))
769 (defgeneric testsuite-run
(testsuite result
)
770 (:documentation
"Run the cases in this suite and it's children."))
772 (defgeneric testsuite-teardown
(testsuite result
)
773 (:documentation
"Cleanup at the testsuite level.")
774 (:method
((testsuite test-mixin
) (result test-result
))
777 (:method
:after
((testsuite test-mixin
) (result test-result
))
778 (setf (current-step testsuite
) :testsuite-teardown
779 (real-end-time result
) (get-internal-real-time)
780 (real-end-time-universal result
) (get-universal-time))))
782 (defgeneric more-prototypes-p
(testsuite)
783 (:documentation
"Returns true if another prototype set exists for the case."))
785 (defgeneric initialize-prototypes
(testsuite)
786 (:documentation
"Creates lists of all prototype sets."))
788 (defgeneric next-prototype
(testsuite)
789 (:documentation
"Ensures that the test environment has the values of the next prototype set."))
791 (defgeneric make-single-prototype
(testsuite))
793 (defgeneric setup-test
(testsuite)
794 (:documentation
"Setup for a test-case. By default it does nothing."))
796 (defgeneric teardown-test
(testsuite)
797 (:documentation
"Tear-down a test-case. By default it does nothing.")
798 (:method-combination progn
:most-specific-first
))
800 (defgeneric testsuite-methods
(testsuite)
801 (:documentation
"Returns a list of the test methods defined for test. I.e.,
802 the methods that should be run to do the tests for this test."))
804 (defgeneric lift-test
(suite name
)
807 (defgeneric do-testing
(testsuite result fn
)
810 (defgeneric end-test
(result case method-name
)
813 (defgeneric initialize-test
(test)
816 (defgeneric run-test-internal
(case name result
)
819 (defgeneric run-tests-internal
(case &key result
)
822 (defgeneric start-test
(result case method-name
)
825 (defgeneric test-report-code
(testsuite method
)
828 (defgeneric testsuite-p
(thing)
829 (: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."))
831 (defgeneric testsuite-name-
>gf
(case name
)
834 (defgeneric testsuite-name-
>method
(class name
)
837 (defmethod setup-test :before
((test test-mixin
))
838 (setf *test-scratchpad
* nil
839 (current-step test
) :test-setup
))
841 (defmethod setup-test ((test test-mixin
))
844 (defmethod teardown-test progn
((test test-mixin
))
847 (defmethod teardown-test :around
((test test-mixin
))
848 (setf (current-step test
) :test-teardown
)
851 (defmethod initialize-test ((test test-mixin
))
854 (defmethod initialize-test :before
((test test-mixin
))
856 (initialize-prototypes test
)
857 (next-prototype test
))
859 (defmethod initialize-instance :after
((testsuite test-mixin
) &key
)
860 (when (null (testsuite-name testsuite
))
861 (setf (slot-value testsuite
'name
)
862 (symbol-name (type-of testsuite
)))))
864 (defmethod print-object ((tc test-mixin
) stream
)
865 (print-unreadable-object (tc stream
:identity t
:type t
)
866 (format stream
"~a" (testsuite-name tc
))))
868 ;;; ---------------------------------------------------------------------------
870 ;;; ---------------------------------------------------------------------------
872 (defvar *current-definition
* nil
873 "An associative-container which saves interesting information about
874 the thing being defined.")
876 (defun initialize-current-definition ()
877 (setf *current-definition
* nil
))
879 (defun set-definition (name value
)
880 (let ((current (assoc name
*current-definition
*)))
882 (setf (cdr current
) value
)
883 (push (cons name value
) *current-definition
*)))
886 (defun def (name &optional
(definition *current-definition
*))
887 (when definition
(cdr (assoc name definition
))))
889 (defun (setf def
) (value name
)
890 (set-definition name value
))
892 (defvar *code-blocks
* nil
)
894 (defstruct (code-block (:type list
) (:conc-name nil
))
895 block-name
(priority 0) filter code operate-when
)
897 (defgeneric block-handler
(name value
)
899 (:method
((name t
) (value t
))
900 (error "Unknown clause: ~A" name
)))
902 (defun add-code-block (name priority operate-when filter handler code
)
903 (let ((current (assoc name
*code-blocks
*))
904 (value (make-code-block
905 :operate-when operate-when
911 (setf (cdr current
) value
)
912 (push (cons name value
) *code-blocks
*))
914 `(defmethod block-handler ((name (eql ',name
)) value
)
915 (declare (ignorable value
))
917 (setf *code-blocks
* (sort *code-blocks
* #'<
918 :key
(lambda (name.cb
)
919 (priority (cdr name.cb
))))))
921 (defmacro with-test-slots
(&body body
)
922 `(symbol-macrolet ((lift-result (getf (test-data *current-test
*) :result
)))
924 ,(mapcar #'(lambda (local)
925 `(,local
(test-environment-value ',local
)))
928 ,(mapcar (lambda (spec)
929 (destructuring-bind (name arglist
) spec
932 *current-test
* ',',name
,,@arglist
))))
933 (def :function-specs
))
936 (defvar *deftest-clauses
*
937 '(:setup
:teardown
:test
:documentation
:tests
:export-p
:export-slots
938 :run-setup
:dynamic-variables
:equality-test
:categories
:function
))
940 (defmacro deftest
(testsuite-name superclasses slots
&rest
942 "The `deftest` form is obsolete, see [deftestsuite][]."
944 (warn "Deftest is obsolete, use deftestsuite instead.")
945 `(deftestsuite ,testsuite-name
,superclasses
,slots
,@clauses-and-options
))
947 (setf *code-blocks
* nil
)
951 (lambda () (or (def :setup
) (def :direct-slot-names
)))
952 '((setf (def :setup
) (cleanup-parsed-parameter value
)))
953 'build-setup-test-method
)
956 :teardown
100 :methods
957 (lambda () (or (def :teardown
) (def :direct-slot-names
)))
958 '((setf (def :teardown
) (cleanup-parsed-parameter value
)))
959 'build-test-teardown-method
)
963 (lambda () (def :functions
))
964 '((push value
(def :functions
)))
965 'build-test-local-functions
)
968 :documentation
0 :class-def
970 '((setf (def :documentation
) (first value
)))
974 :export-p
0 :class-def
976 '((setf (def :export-p
) (first value
)))
980 :export-slots
0 :class-def
982 '((setf (def :export-slots
) (first value
)))
986 :run-setup
0 :class-def
988 '((push (first value
) (def :default-initargs
))
989 (push :run-setup
(def :default-initargs
))
990 (setf (def :run-setup
) (first value
)))
994 :equality-test
0 :class-def
996 '((push (first value
) (def :default-initargs
))
997 (push :equality-test
(def :default-initargs
)))
1001 :log-file
0 :class-def
1003 '((push (first value
) (def :default-initargs
))
1004 (push :log-file
(def :default-initargs
)))
1008 :dynamic-variables
0 :class-def
1010 '((setf (def :direct-dynamic-variables
) value
))
1014 :categories
0 :class-def
1016 '((push value
(def :categories
)))
1019 (defmacro no-handler-case
(form &rest cases
)
1020 (declare (ignore cases
))
1023 (defmacro deftestsuite
(testsuite-name superclasses slots
&rest
1024 clauses-and-options
)
1026 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.
1028 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.
1030 Slots are specified as in defclass with the following additions:
1032 * 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)`.
1033 * 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
1035 (deftestsuite my-test ()
1038 then `my-slot` will be initialized to 23 during test setup.
1040 Test options are one of :setup, :teardown, :test, :tests, :documentation, :export-p, :dynamic-variables, :export-slots, :function, :categories, :run-setup, or :equality-test.
1042 * :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.
1044 * :documentation - a string specifying any documentation for the test. Should only be specified once.
1046 * :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.
1048 * :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.
1050 * :export-p - If true, the testsuite name will be exported from the current package. Should only be specified once.
1052 * :export-slots - if true, any slots specified in the test suite will be exported from the current package. Should only be specified once.
1054 * :function - creates a locally accessible function for this test suite. May be specified multiple times.
1056 * :run-setup - specify when to run the setup code for this test suite. Allowed values are
1058 * :once-per-test-case or t (the default)
1063 :run-setup is handy when a testsuite has a time consuming setup phase that you do not want to repeat for every test.
1065 * :setup - a list of forms to be evaluated before each test case is run. Should only be specified once.
1067 * :teardown - a list of forms to be evaluated after each test case is run. Should only be specified once.
1069 * :test - Define a single test case. Can be specified multiple times.
1071 * :tests - Define multiple test cases for this test suite. Can be specified multiple times.
1077 (let ((test-list nil
)
1080 ;; convert any clause like :setup foo into (:setup foo)
1081 (setf clauses-and-options
1082 (convert-clauses-into-lists clauses-and-options
*deftest-clauses
*))
1083 (initialize-current-definition)
1084 (setf (def :testsuite-name
) testsuite-name
)
1085 (setf (def :superclasses
) (mapcar #'find-testsuite superclasses
))
1086 (setf (def :deftestsuite
) t
)
1087 ;; parse clauses into defs
1088 (loop for clause in clauses-and-options do
1090 (symbol (pushnew clause options
))
1091 (cons (destructuring-bind (kind &rest spec
) clause
1093 (:test
(push (first spec
) test-list
))
1095 (loop for test in spec do
1096 (push test test-list
)))
1097 (t (block-handler kind spec
)))))
1098 (t (error "When parsing ~S" clause
))))
1099 (let ((slot-names nil
) (slot-specs nil
))
1100 (loop for slot in
(if (listp slots
) slots
(list slots
)) do
1101 (push (if (consp slot
) (first slot
) slot
) slot-names
)
1102 (push (parse-brief-slot slot nil nil nil nil
) slot-specs
))
1103 (setf (def :slot-specs
) (nreverse slot-specs
)
1104 (def :direct-slot-names
) (nreverse slot-names
)
1105 (def :slots-parsed
) t
))
1106 ;;?? issue 27: breaks 'encapsulation' of code-block mechanism
1107 (setf (def :function-specs
)
1108 (loop for spec in
(def :functions
) collect
1109 (destructuring-bind (name arglist
&body body
) (first spec
)
1110 (declare (ignore body
))
1111 `(,name
,arglist
))))
1113 (empty-test-tables testsuite-name
)
1114 (compute-superclass-inheritence)
1116 (setf *testsuite-test-count
* 0)
1117 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
1118 (eval-when (:compile-toplevel
)
1119 (push ',return
*test-is-being-compiled?
*))
1120 (eval-when (:load-toplevel
)
1121 (push ',return
*test-is-being-loaded?
*))
1122 (eval-when (:execute
)
1123 (push ',return
*test-is-being-executed?
*))
1125 (let (#+MCL
(ccl:*warn-if-redefine
* nil
)
1126 (*test-is-being-defined?
* t
))
1129 ;; remove previous methods (do this
1130 ;; _before_ we define the class)
1132 (remove-previous-definitions ',(def :testsuite-name
))
1133 (setf *current-case-method-name
* nil
)
1134 ;; and then redefine the class
1136 (setf *current-suite-class-name
* ',(def :testsuite-name
)
1137 (test-slots ',(def :testsuite-name
))
1139 (testsuite-dynamic-variables ',(def :testsuite-name
))
1140 ',(def :dynamic-variables
)
1141 ;;?? issue 27: breaks 'encapsulation' of code-block mechanism
1142 (testsuite-function-specs ',(def :testsuite-name
))
1143 ',(def :function-specs
))
1144 ,@(when (def :export-p
)
1145 `((export '(,(def :testsuite-name
)))))
1146 ,@(when (def :export-slots?
)
1147 `((export ',(def :direct-slot-names
))))
1148 ;; make a place to save test-case information
1149 (empty-test-tables ',(def :testsuite-name
))
1152 (eval-when (:load-toplevel
:execute
)
1153 ,@(build-initialize-test-method)
1154 ,@(loop for
(nil . block
) in
*code-blocks
*
1157 (eq (operate-when block
) :methods
)
1158 (or (not (filter block
))
1159 (funcall (filter block
)))) collect
1160 (funcall (code block
)))
1161 ,@(when (def :dynamic-variables
)
1162 `((defmethod do-testing :around
1163 ((suite ,(def :testsuite-name
)) result fn
)
1164 (declare (ignore result fn
))
1165 (cond ((done-dynamics? suite
)
1168 (setf (slot-value suite
'done-dynamics?
) t
)
1169 (let* (,@(build-dynamics))
1170 (call-next-method)))))))
1173 `((let ((*test-evaluate-when-defined?
* nil
))
1174 ,@(loop for test in
(nreverse test-list
) collect
1175 `(addtest (,(def :testsuite-name
))
1177 (setf *testsuite-test-count
* nil
))))
1178 ,(if *test-evaluate-when-defined?
*
1179 `(unless (or *test-is-being-compiled?
*
1180 *test-is-being-loaded?
*)
1181 (let ((*test-break-on-errors?
* *test-break-on-errors?
*))
1182 (run-tests :suite
',testsuite-name
)))
1183 `(find-class ',testsuite-name
))))
1186 (setf *testsuite-test-count
* nil
)
1187 (lift-report-condition c
))))
1189 (setf *test-is-being-compiled?
*
1190 (remove ',return
*test-is-being-compiled?
*))
1191 (setf *test-is-being-loaded?
*
1192 (remove ',return
*test-is-being-loaded?
*))
1193 (setf *test-is-being-executed?
*
1194 (remove ',return
*test-is-being-executed?
*)))))))
1196 (defun compute-superclass-inheritence ()
1197 ;;?? issue 27: break encapsulation of code blocks
1198 ;;?? we assume that we won't have too deep a hierarchy or too many
1199 ;; dv's or functions so that having lots of duplicate names is OK
1201 (dynamic-variables nil
)
1202 (function-specs nil
))
1203 (dolist (super (def :superclasses
))
1204 (cond ((find-testsuite super
)
1205 (setf slots
(append slots
(test-slots super
))
1207 (append dynamic-variables
1208 (testsuite-dynamic-variables super
))
1210 (append function-specs
1211 (testsuite-function-specs super
))))
1213 (error 'test-class-not-defined
:test-class-name super
))))
1214 (setf (def :slot-names
)
1215 (remove-duplicates (append (def :direct-slot-names
) slots
))
1216 (def :dynamic-variables
)
1218 (append (def :direct-dynamic-variables
) dynamic-variables
))
1219 (def :function-specs
)
1221 (append (def :function-specs
) function-specs
)))
1222 (setf (def :superclasses
)
1223 (loop for class in
(def :superclasses
)
1224 unless
(some (lambda (oter)
1225 (and (not (eq class oter
))
1226 (member class
(superclasses oter
))))
1227 (def :superclasses
)) collect
1230 (defmacro addtest
(name &body test
)
1231 "Adds a single new test-case to the most recently defined testsuite."
1239 (looks-like-suite-name (looks-like-suite-name-p name
))
1240 (looks-like-code (looks-like-code-p name
)))
1241 (cond ((and looks-like-suite-name looks-like-code
)
1242 (error "Can't disambiguate suite name from possible code."))
1243 (looks-like-suite-name
1245 (setf (def :testsuite-name
) (first name
)
1247 name nil body test
))
1249 ;; the 'name' is really part of the test...
1250 (setf body
(cons name test
))))
1251 (unless (def :testsuite-name
)
1252 (when *current-suite-class-name
*
1253 (setf (def :testsuite-name
) *current-suite-class-name
*)))
1254 (unless (def :testsuite-name
)
1255 (signal-lift-error 'add-test
+lift-no-current-test-class
+))
1256 (unless (or (def :deftestsuite
)
1257 (find-testsuite (def :testsuite-name
)))
1258 (signal-lift-error 'add-test
+lift-test-class-not-found
+
1259 (def :testsuite-name
)))
1260 `(eval-when (:compile-toplevel
:load-toplevel
:execute
)
1261 (eval-when (:compile-toplevel
)
1262 (push ',return
*test-is-being-compiled?
*))
1263 (eval-when (:load-toplevel
)
1264 (push ',return
*test-is-being-loaded?
*))
1265 (eval-when (:execute
)
1266 (push ',return
*test-is-being-executed?
*))
1268 (let ((*test-is-being-defined?
* t
))
1269 ,(build-test-test-method (def :testsuite-name
) body options
)
1270 (setf *current-suite-class-name
* ',(def :testsuite-name
))
1271 (if *test-evaluate-when-defined?
*
1272 (unless (or *test-is-being-compiled?
*
1273 *test-is-being-loaded?
*)
1274 (let ((*test-break-on-errors?
* (testing-interactively-p)))
1278 (setf *test-is-being-compiled?
*
1279 (remove ',return
*test-is-being-compiled?
*)
1280 *test-is-being-loaded?
*
1281 (remove ',return
*test-is-being-loaded?
*)
1282 *test-is-being-executed?
*
1283 (remove ',return
*test-is-being-executed?
*)))))
1285 (lift-report-condition c
))))
1287 (defun looks-like-suite-name-p (form)
1290 (find-testsuite (first form
))
1291 (property-list-p (rest form
))))
1293 (defun property-list-p (form)
1298 for want-keyword?
= t then
(not want-keyword?
) do
1299 (when (and want-keyword?
(not (keywordp x
)))
1300 (return-from check-it nil
))
1301 (setf even?
(not even?
)))
1302 (return-from check-it even?
)))))
1305 (property-list-p '(:a
:b
))
1306 (property-list-p '(:a
2 :b
3 :c
5 :d
8))
1307 (property-list-p nil
)
1310 (property-list-p '(3))
1311 (property-list-p '(3 :a
))
1312 (property-list-p '(:a
3 :b
))
1315 (defun looks-like-code-p (name)
1316 (declare (ignore name
))
1320 (defun remove-test (&key
(name *current-case-method-name
*)
1321 (suite *current-suite-class-name
*))
1322 (assert suite nil
"Test suite could not be determined.")
1323 (assert name nil
"Test name could not be determined.")
1324 (setf (testsuite-tests suite
)
1325 (remove name
(testsuite-tests suite
))))
1327 (defun run-test (&rest args
1328 &key
(name *current-case-method-name
*)
1329 (suite *current-suite-class-name
*)
1330 (break-on-errors?
*test-break-on-errors?
*)
1331 (do-children?
*test-do-children?
*)
1333 (assert suite nil
"Test suite could not be determined.")
1334 (assert name nil
"Test name could not be determined.")
1335 (let* ((*test-break-on-errors?
* break-on-errors?
)
1336 (*test-do-children?
* do-children?
)
1337 (*current-test
* (make-testsuite suite args
)))
1339 (setf result
(make-test-result suite
:single
)))
1340 (setf *current-case-method-name
* name
1341 *current-suite-class-name
* suite
)
1342 (do-testing *current-test
* result
1344 (run-test-internal *current-test
* name result
)))))
1346 (defun make-testsuite (suite args
)
1347 (let ((make-instance-args nil
))
1348 (loop for keyword in
*make-testsuite-arguments
* do
1349 (when (member keyword args
)
1350 (push keyword make-instance-args
)
1351 (push (getf args keyword
) make-instance-args
)))
1352 (apply #'make-instance
(find-testsuite suite
) make-instance-args
)))
1354 (defmethod do-testing ((testsuite test-mixin
) result fn
)
1357 (testsuite-setup testsuite result
)
1358 (let ((*lift-equality-test
* (equality-test testsuite
)))
1360 ((not (more-prototypes-p testsuite
)) result
)
1361 (initialize-test testsuite
)
1364 (testsuite-teardown testsuite result
))
1367 (defmethod run-tests-internal ((suite symbol
) &rest args
&key
&allow-other-keys
)
1368 (let ((*current-test
* (make-testsuite suite args
)))
1369 (apply #'run-tests-internal
1373 (defmethod run-tests-internal
1374 ((case test-mixin
) &key
1375 (result (make-test-result (class-of case
) :multiple
))
1376 (do-children?
*test-do-children?
*))
1377 (let ((*test-do-children?
* do-children?
))
1378 (do-testing case result
1380 (testsuite-run case result
)))
1381 (setf *test-result
* result
)))
1384 (defmacro with-test
(&body forms
)
1385 "Execute forms in the context of the current test class."
1386 (let* ((test-class-name *current-suite-class-name
*)
1387 (test-case (make-instance test-class
)))
1388 `(eval-when (:execute
)
1390 (setup-test ,test-case
)
1392 (with-test-slots ,@forms
))
1393 (teardown-test ,test-case
)))))
1395 (defun map-testsuites (fn start-at
)
1396 (let ((visited (make-hash-table)))
1397 (labels ((do-it (suite level
)
1398 (unless (gethash suite visited
)
1399 (setf (gethash suite visited
) t
)
1400 (funcall fn suite level
)
1401 (loop for subclass in
(subclasses suite
:proper? t
) do
1402 (do-it subclass
(1+ level
))))))
1403 (do-it (find-class (find-testsuite start-at
) nil
) 0))))
1405 (defun testsuites (&optional
(start-at 'test-mixin
))
1406 "Returns a list of testsuite classes. The optional parameter provides
1407 control over where in the test hierarchy the search begins."
1409 (map-testsuites (lambda (suite level
)
1410 (declare (ignore level
))
1411 (push suite result
))
1415 (defun print-tests (&key
(include-cases? t
) (start-at 'test-mixin
) (stream t
))
1416 "Prints all of the defined test classes from :start-at on down."
1418 (lambda (suite level
)
1419 (let ((indent (coerce (make-list (* level
3) :initial-element
#\Space
)
1421 (name (class-name suite
)))
1422 (format stream
"~&~a~s (~:d)"
1425 (length (testsuite-methods name
)))
1426 (when include-cases?
1427 (loop for method-name in
(testsuite-tests name
) do
1428 (format stream
"~&~a ~a" indent method-name
)))))
1431 (defun list-tests (&key
(include-cases? t
) (start-at 'test-mixin
) (stream t
))
1432 "Lists all of the defined test classes from :start-at on down."
1433 (mapc (lambda (subclass-name)
1434 (format stream
"~&~s (~:d)"
1436 (length (testsuite-methods subclass-name
)))
1437 (when include-cases?
1438 (loop for method-name in
(testsuite-tests subclass-name
) do
1439 (format stream
"~& ~a" method-name
))))
1440 (testsuites start-at
))
1443 (defun testsuite-test-count (testsuite)
1444 (or (and *testsuite-test-count
*
1445 (prog1 *testsuite-test-count
* (incf *testsuite-test-count
*)))
1446 (length (testsuite-methods testsuite
))))
1448 (defun run-tests (&rest args
&key
1450 (break-on-errors?
*test-break-on-errors?
*)
1452 (dribble *lift-dribble-pathname
*)
1453 (result (make-test-result (or suite config
) :multiple
))
1456 "Run all of the tests in a suite. Arguments are :suite, :result,
1457 :do-children? and :break-on-errors?"
1459 (remf args
:break-on-errors?
)
1460 (remf args
:run-setup
)
1461 (remf args
:dribble
)
1462 (cond ((and suite config
)
1463 (error "Specify either configuration file or test suite
1466 (run-tests-from-file config
))
1467 ((or suite
(setf suite
*current-suite-class-name
*))
1468 (let* ((*test-break-on-errors?
* break-on-errors?
)
1473 :if-does-not-exist
:create
1474 :if-exists
*lift-if-dribble-exists
*)))
1475 (*standard-output
* (maybe-add-dribble
1476 *lift-standard-output
* dribble-stream
))
1477 (*error-output
* (maybe-add-dribble
1478 *error-output
* dribble-stream
))
1479 (*debug-io
* (maybe-add-dribble
1480 *debug-io
* dribble-stream
)))
1482 (dolist (name (if (consp suite
) suite
(list suite
)))
1483 (setf *current-suite-class-name
* name
)
1484 (apply #'run-tests-internal name
:result result args
))
1486 (when dribble-stream
1487 (close dribble-stream
)))
1489 (setf (tests-run result
) (reverse (tests-run result
)))
1492 (error "There is not a current test suite and neither suite
1493 nor configuration file options were specified."))))
1495 (defun maybe-add-dribble (stream dribble-stream
)
1497 (values (make-broadcast-stream stream dribble-stream
) t
)
1498 (values stream nil
)))
1500 (defmethod testsuite-run ((case test-mixin
) (result test-result
))
1501 (unless (start-time result
)
1502 (setf (start-time result
) (get-internal-real-time)
1503 (start-time-universal result
) (get-universal-time)))
1505 (let ((methods (testsuite-methods case
)))
1506 (loop for method in methods do
1507 (run-test-internal case method result
))
1508 (when *test-do-children?
*
1509 (loop for subclass in
(direct-subclasses (class-of case
))
1510 when
(and (testsuite-p subclass
)
1511 (not (member (class-name subclass
)
1512 (suites-run result
)))) do
1513 (run-tests-internal (class-name subclass
)
1515 (setf (end-time result
) (get-universal-time))))
1517 (defmethod more-prototypes-p ((testsuite test-mixin
))
1518 (not (null (prototypes testsuite
))))
1520 (defmethod initialize-prototypes ((testsuite test-mixin
))
1521 (setf (prototypes testsuite
)
1522 (list (make-single-prototype testsuite
))))
1524 (defmethod make-single-prototype ((testsuite test-mixin
))
1527 (defmethod initialize-prototypes :around
((suite test-mixin
))
1528 (unless (prototypes-initialized? suite
)
1529 (setf (slot-value suite
'prototypes-initialized?
) t
)
1530 (call-next-method)))
1532 (defmethod next-prototype ((testsuite test-mixin
))
1533 (setf (current-values testsuite
) (first (prototypes testsuite
))
1534 (prototypes testsuite
) (rest (prototypes testsuite
)))
1535 (dolist (key.value
(current-values testsuite
))
1536 (setf (test-environment-value (car key.value
)) (cdr key.value
))))
1538 (defmethod run-test-internal ((case test-mixin
) (name symbol
) result
)
1539 (when (and *test-print-test-case-names
*
1540 (eq (test-mode result
) :multiple
))
1541 (print-lift-message "~& run: ~a" name
))
1542 (let ((problem nil
))
1544 (declare (ignorable problem
))
1548 (handler-bind ((warning #'muffle-warning
)
1549 ; ignore warnings...
1553 (report-test-problem
1554 'test-error result case name cond
1555 :backtrace
(get-backtrace cond
)))
1556 (if *test-break-on-errors?
*
1557 (invoke-debugger cond
)
1560 ;; FIXME - too much! should we catch serious-conditions?
1563 (report-test-problem
1564 'test-error result case name cond
1565 :backtrace
(get-backtrace cond
))))))
1567 (current-method case
) name
)
1568 (start-test result case name
)
1572 (declare (ignorable result
))
1573 (setf (current-step case
) :testing
1576 (getf (test-data case
) :seconds
)
1577 (getf (test-data case
) :conses
)
1578 (lift-test case name
)))
1579 (check-for-surprises result case name
))
1580 (teardown-test case
)
1581 (end-test result case name
)))
1582 (ensure-failed (cond)
1584 (report-test-problem
1585 'test-failure result case name cond
)))
1586 (retry-test () :report
"Retry the test."
1589 (setf (third (first (tests-run result
))) (test-data case
))
1590 (setf *test-result
* result
))
1592 (define-condition unexpected-success-failure
(test-condition)
1593 ((expected :reader expected
:initarg
:expected
)
1594 (expected-more :reader expected-more
:initarg
:expected-more
))
1595 (:report
(lambda (c s
)
1596 (format s
"Test succeeded but we expected ~s (~s)"
1598 (expected-more c
)))))
1600 (defun check-for-surprises (results testsuite name
)
1601 (declare (ignore results name
))
1602 (let* ((options (getf (test-data testsuite
) :options
))
1603 (expected-failure-p (second (member :expected-failure options
)))
1604 (expected-error-p (second (member :expected-error options
)))
1605 (expected-problem-p (second (member :expected-problem options
)))
1609 (setf (slot-value testsuite
'expected-failure-p
) expected-failure-p
))
1611 (setf (slot-value testsuite
'expected-error-p
) expected-error-p
))
1613 (setf (slot-value testsuite
'expected-problem-p
) expected-problem-p
)))
1615 ((expected-failure-p testsuite
)
1617 (make-condition 'unexpected-success-failure
1619 :expected-more
(expected-failure-p testsuite
))))
1620 ((expected-error-p testsuite
)
1622 (make-condition 'unexpected-success-failure
1624 :expected-more
(expected-error-p testsuite
))))
1625 ((expected-problem-p testsuite
)
1627 (make-condition 'unexpected-success-failure
1629 :expected-more
(expected-problem-p testsuite
)))))
1631 (if (find-restart 'ensure-failed
)
1632 (invoke-restart 'ensure-failed condition
)
1633 (warn condition
)))))
1635 (defun report-test-problem (problem-type result suite method condition
1639 (options (getf (test-data suite
) :options
))
1641 (declare (ignore docs option
))
1642 (cond ((and (eq problem-type
'test-failure
)
1643 (not (typep condition
'unexpected-success-failure
))
1644 (member :expected-failure options
))
1645 (setf problem-type
'test-expected-failure
1646 option
:expected-failure
))
1647 ((and (eq problem-type
'test-error
)
1648 (member :expected-error
(getf (test-data suite
) :options
)))
1649 (setf problem-type
'test-expected-error
1650 option
:expected-error
))
1651 ((and (or (eq problem-type
'test-failure
)
1652 (eq problem-type
'test-error
))
1653 (member :expected-problem
(getf (test-data suite
) :options
)))
1654 (setf problem-type
(or (and (eq problem-type
'test-failure
)
1655 'test-expected-failure
)
1656 (and (eq problem-type
'test-error
)
1657 'test-expected-error
))
1658 option
:expected-problem
)))
1659 (let ((problem (apply #'make-instance problem-type
1662 :test-condition condition
1663 :test-step
(current-step suite
) args
)))
1664 (setf (getf (test-data suite
) :problem
) problem
)
1666 (test-failure (push problem
(failures result
)))
1667 (test-expected-failure (push problem
(expected-failures result
)))
1668 (test-error (push problem
(errors result
)))
1669 (test-expected-error (push problem
(expected-errors result
))))
1672 ;;; ---------------------------------------------------------------------------
1673 ;;; test-result and printing
1674 ;;; ---------------------------------------------------------------------------
1676 (defun get-test-print-length ()
1677 (let ((foo *test-print-length
*))
1678 (if (eq foo
:follow-print
) *print-length
* foo
)))
1680 (defun get-test-print-level ()
1681 (let ((foo *test-print-level
*))
1682 (if (eq foo
:follow-print
) *print-level
* foo
)))
1684 (defmethod start-test ((result test-result
) (case test-mixin
) name
)
1685 (push (list (type-of case
) name nil
) (tests-run result
))
1686 (setf (current-step case
) :start-test
1688 `(:start-time
,(get-internal-real-time)
1689 :start-time-universal
,(get-universal-time))))
1691 (defmethod end-test ((result test-result
) (testsuite test-mixin
) name
)
1692 (declare (ignore name
))
1693 (setf (current-step testsuite
) :end-test
1694 (getf (test-data testsuite
) :end-time
) (get-internal-real-time)
1695 (end-time result
) (get-internal-real-time)
1696 (getf (test-data testsuite
) :end-time-universal
) (get-universal-time)
1697 (end-time-universal result
) (get-universal-time)))
1699 (defun make-test-result (for test-mode
)
1700 (make-instance 'test-result
1702 :test-mode test-mode
))
1704 (defun testing-interactively-p ()
1707 (defmethod print-object ((tr test-result
) stream
)
1708 (let ((complete-success?
(and (null (errors tr
))
1709 (null (failures tr
))
1710 (null (expected-failures tr
))
1711 (null (expected-errors tr
)))))
1712 (let* ((*print-level
* (get-test-print-level))
1713 (*print-length
* (get-test-print-length)))
1714 (print-unreadable-object (tr stream
)
1715 (cond ((null (tests-run tr
))
1716 (format stream
"~A: no tests defined" (results-for tr
)))
1717 ((eq (test-mode tr
) :single
)
1718 (cond ((test-interactive? tr
)
1720 (cond (complete-success?
1721 (format stream
"Test passed"))
1723 (format stream
"Error during testing"))
1724 ((expected-errors tr
)
1725 (format stream
"Expected error during testing"))
1727 (format stream
"Test failed"))
1729 (format stream
"Test failed expectedly"))))
1732 (format stream
"~A.~A ~A"
1734 (first (first (tests-run tr
)))
1735 (cond (complete-success?
1741 (when (or (expected-errors tr
) (expected-failures tr
))
1742 (format stream
"(~[~:;, ~:*~A expected failure~:P~]~[~:;, ~:*~A expected error~:P~])"
1743 (expected-failures tr
) (expected-errors tr
))))))
1745 ;; multiple tests run
1746 (format stream
"Results for ~A " (results-for tr
))
1747 (if complete-success?
1748 (format stream
"[~A Successful test~:P]"
1749 (length (tests-run tr
)))
1750 (format stream
"~A Test~:P~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Error~:P~]~[~:;, ~:*~A Expected failure~:P~]~[~:;, ~:*~A Expected error~:P~]"
1751 (length (tests-run tr
))
1752 (length (failures tr
))
1753 (length (errors tr
))
1754 (length (expected-failures tr
))
1755 (length (expected-errors tr
))))))
1756 ;; note that suites with no tests think that they are completely
1757 ;; successful. Optimistic little buggers, huh?
1758 (when (and (not complete-success?
) *test-describe-if-not-successful?
*)
1759 (format stream
"~%")
1760 (print-test-result-details stream tr
))))))
1762 (defmethod describe-object ((result test-result
) stream
)
1763 (let ((number-of-failures (length (failures result
)))
1764 (number-of-expected-failures (length (expected-failures result
)))
1765 (number-of-errors (length (errors result
)))
1766 (number-of-expected-errors (length (expected-errors result
))))
1767 (unless *test-is-being-defined?
*
1768 (format stream
"~&Test Report for ~A: ~D test~:P run"
1769 (results-for result
) (length (tests-run result
))))
1770 (let* ((*print-level
* (get-test-print-level))
1771 (*print-length
* (get-test-print-length)))
1772 (cond ((or (failures result
) (errors result
)
1773 (expected-failures result
) (expected-errors result
))
1774 (format stream
"~[~:;, ~:*~A Failure~:P~]~[~:;, ~:*~A Expected failure~:P~]~[~:;, ~:*~A Error~:P~]~[~:;, ~:*~A Expected error~:P~]."
1776 number-of-expected-failures
1778 number-of-expected-errors
)
1779 (format stream
"~%~%")
1780 (print-test-result-details stream result
))
1781 ((or (expected-failures result
) (expected-errors result
))
1782 (format stream
", all passed *~[~:;, ~:*~A Expected failure~:P~]~[~:;, ~:*~A Expected error~:P~])."
1783 number-of-expected-failures
1784 number-of-expected-errors
)
1785 (format stream
"~%~%")
1786 (print-test-result-details stream result
))
1788 (unless *test-is-being-defined?
*
1789 (format stream
", all passed!")))))
1792 (defun print-test-result-details (stream result
)
1793 (loop for report in
(failures result
) do
1794 (print-test-problem "Failure: " report stream
))
1795 (loop for report in
(errors result
) do
1796 (print-test-problem "ERROR : " report stream
))
1797 (loop for report in
(expected-failures result
) do
1798 (print-test-problem "Expected failure: " report stream
))
1799 (loop for report in
(expected-errors result
) do
1800 (print-test-problem "Expected Error : " report stream
)))
1802 (defun print-test-problem (prefix report stream
)
1803 (let* ((suite (testsuite report
))
1804 (method (test-method report
))
1805 (condition (test-condition report
))
1806 (code (test-report-code suite method
))
1807 (testsuite-name method
))
1808 (format stream
"~&~A~(~A : ~A~)" prefix
(type-of suite
) testsuite-name
)
1809 (let ((doc-string (gethash testsuite-name
1810 (test-case-documentation
1811 (class-name (class-of suite
))))))
1813 (format stream
"~&~A" doc-string
)))
1814 (format stream
"~&~< ~@;~
1815 ~@[Condition: ~<~@;~A~:>~]~
1817 ~&~:>" (list (list condition
) code
))))
1820 ;;; ---------------------------------------------------------------------------
1822 ;;; ---------------------------------------------------------------------------
1824 (defclass test-problem-mixin
()
1825 ((testsuite :initform nil
:initarg
:testsuite
:reader testsuite
)
1826 (test-method :initform nil
:initarg
:test-method
:reader test-method
)
1827 (test-condition :initform nil
1828 :initarg
:test-condition
1829 :reader test-condition
)
1830 (test-problem-kind :reader test-problem-kind
:allocation
:class
)
1831 (test-step :initform nil
:initarg
:test-step
:reader test-step
)))
1833 (defmethod print-object ((problem test-problem-mixin
) stream
)
1834 (print-unreadable-object (problem stream
)
1835 (format stream
"TEST-~@:(~A~): ~A in ~A"
1836 (test-problem-kind problem
)
1837 (name (testsuite problem
))
1838 (test-method problem
))))
1840 (defclass generic-problem
(test-problem-mixin)
1841 ((test-problem-kind :initarg
:test-problem-kind
1842 :allocation
:class
)))
1844 (defclass expected-problem-mixin
()
1845 ((documentation :initform nil
1846 :initarg
:documentation
1847 :accessor failure-documentation
)))
1849 (defclass test-expected-failure
(expected-problem-mixin generic-problem
)
1852 :test-problem-kind
"Expected failure"))
1854 (defclass test-failure
(generic-problem)
1857 :test-problem-kind
"failure"))
1859 (defclass test-error-mixin
(generic-problem)
1860 ((backtrace :initform nil
:initarg
:backtrace
:reader backtrace
)))
1862 (defclass test-expected-error
(expected-problem-mixin test-error-mixin
)
1865 :test-problem-kind
"Expected error"))
1867 (defclass test-error
(test-error-mixin)
1870 :test-problem-kind
"Error"))
1872 (defmethod test-report-code ((testsuite test-mixin
) (method symbol
))
1873 (let* ((class-name (class-name (class-of testsuite
))))
1875 (test-name->code-table class-name
))))
1877 ;;; ---------------------------------------------------------------------------
1879 ;;; ---------------------------------------------------------------------------
1881 (defun remove-test-methods (test-name)
1883 (length (testsuite-tests test-name
))
1884 (setf (testsuite-tests test-name
) nil
)))
1886 (defun remove-previous-definitions (classname)
1887 "Remove the methods of this class and all its subclasses."
1888 (let ((classes-removed nil
)
1889 (class (find-class classname nil
))
1892 (loop for subclass in
(subclasses class
:proper? nil
) do
1893 (push subclass classes-removed
)
1895 (remove-test-methods (class-name subclass
)))
1897 ;;?? causing more trouble than it solves...??
1898 (setf (find-class (class-name subclass
)) nil
))
1900 (unless (length-1-list-p classes-removed
)
1902 "~&;;; Removed Test suite ~(~A~) and its subclasses (~{~<~s~>~^, ~})."
1905 (mapcar #'class-name classes-removed
))
1907 (unless (zerop removed-count
)
1909 "~&;;; Removed ~D methods from test suite ~(~A~)~@[ and its subclasses~]."
1910 removed-count classname
1911 (not (length-1-list-p classes-removed
)))))))
1913 (defun build-initialize-test-method ()
1914 (let ((initforms nil
)
1916 (slot-specs (def :slot-specs
)))
1917 (loop for slot in slot-specs do
1918 (when (and (member :initform
(rest slot
))
1919 (not (eq :unbound
(getf (rest slot
) :initform
))))
1920 (push (getf (rest slot
) :initform
) initforms
)
1921 (push (first slot
) slot-names
)))
1922 (setf slot-names
(nreverse slot-names
)
1923 initforms
(nreverse initforms
))
1925 `((defmethod make-single-prototype ((testsuite ,(def :testsuite-name
)))
1928 (when (next-method-p)
1930 (let* (,@(mapcar (lambda (slot-name initform
)
1931 `(,slot-name
,initform
))
1932 slot-names initforms
))
1933 (list ,@(mapcar (lambda (slot-name)
1934 `(cons ',slot-name
,slot-name
))
1935 slot-names
))))))))))
1937 (defun (setf test-environment-value
) (value name
)
1938 (pushnew (cons name value
) *test-environment
* :test
#'equal
)
1941 (defun test-environment-value (name)
1942 (cdr (assoc name
*test-environment
*)))
1944 (defun remove-from-test-environment (name)
1945 (setf *test-environment
*
1946 (remove name
*test-environment
* :key
#'car
)))
1948 (defun build-test-local-functions ()
1951 (lambda (function-spec)
1952 (destructuring-bind (name arglist
&body body
) (first function-spec
)
1953 `(defmethod flet-test-function ((testsuite ,(def :testsuite-name
))
1954 (function-name (eql ',name
))
1958 `(destructuring-bind ,arglist args
1960 `(progn ,@body
))))))
1963 (defun build-test-teardown-method ()
1964 (let ((test-name (def :testsuite-name
))
1965 (slot-names (def :direct-slot-names
))
1966 (teardown (def :teardown
)))
1968 (unless (consp teardown
)
1969 (setf teardown
(list teardown
)))
1970 (when (length-1-list-p teardown
)
1971 (setf teardown
(list teardown
)))
1972 (when (symbolp (first teardown
))
1973 (setf teardown
(list teardown
))))
1974 (let* ((teardown-code `(,@(when teardown
1975 `((with-test-slots ,@teardown
)))))
1976 (test-code `(,@teardown-code
1977 ,@(mapcar (lambda (slot)
1978 `(remove-from-test-environment ',slot
))
1981 ,@(when teardown-code
1982 `((defmethod teardown-test progn
((testsuite ,test-name
))
1983 (when (run-teardown-p testsuite
:test-case
)
1985 ,@(when teardown-code
1986 `((defmethod testsuite-teardown ((testsuite ,test-name
)
1987 (result test-result
))
1988 (when (run-teardown-p testsuite
:testsuite
)
1991 (defun build-setup-test-method ()
1992 (let ((test-name (def :testsuite-name
))
1993 (setup (def :setup
)))
1995 (unless (consp setup
)
1996 (setf setup
(list setup
)))
1997 (when (length-1-list-p setup
)
1998 (setf setup
(list setup
)))
1999 (when (symbolp (first setup
))
2000 (setf setup
(list setup
)))
2001 (let ((code `((with-test-slots ,@setup
))))
2003 (defmethod setup-test :after
((testsuite ,test-name
))
2006 (defmethod setup-test :around
((test test-mixin
))
2007 (when (run-setup-p test
)
2009 (setf (slot-value test
'done-setup?
) t
)))
2011 (defun run-setup-p (testsuite)
2012 (case (run-setup testsuite
)
2013 (:once-per-session
(error "not implemented"))
2014 (:once-per-suite
(not (done-setup? testsuite
)))
2015 ((:once-per-test-case t
) t
)
2017 (t (error "Don't know about ~s for run-setup" (run-setup testsuite
)))))
2019 (defun run-teardown-p (testsuite when
)
2022 (ecase (run-setup testsuite
)
2023 (:once-per-session nil
)
2024 (:once-per-suite nil
)
2025 ((:once-per-test-case t
) t
)
2026 ((:never nil
) nil
)))
2028 (ecase (run-setup testsuite
)
2029 (:once-per-session nil
)
2031 ((:once-per-test-case t
) nil
)
2032 ((:never nil
) nil
)))))
2034 (defun build-test-test-method (test-class test-body options
)
2035 (multiple-value-bind (test-name body documentation name-supplied?
)
2036 (parse-test-body test-body
)
2037 (declare (ignorable name-supplied?
))
2038 (unless (consp (first body
))
2039 (setf body
(list body
)))
2041 (setf (gethash ',test-name
(test-name->code-table
',test-class
)) ',body
2042 (gethash ',body
(test-code->name-table
',test-class
)) ',test-name
)
2043 ,(when documentation
2044 `(setf (gethash ',test-name
(test-case-documentation ',test-class
))
2047 ,@(when name-supplied?
2048 `((ccl:record-source-file
',test-name
'test-case
)))
2049 (unless (find ',test-name
(testsuite-tests ',test-class
))
2050 (setf (testsuite-tests ',test-class
)
2051 (append (testsuite-tests ',test-class
) (list ',test-name
))))
2052 (defmethod lift-test ((testsuite ,test-class
) (case (eql ',test-name
)))
2054 `((setf (getf (test-data testsuite
) :options
) ',options
)))
2055 (with-test-slots ,@body
))
2056 (setf *current-case-method-name
* ',test-name
)
2057 (when (and *test-print-when-defined?
*
2058 (not (or *test-is-being-compiled?
*
2060 (format *debug-io
* "~&;Test Created: ~(~S.~S~)."
2061 ',test-class
',test-name
))
2062 *current-case-method-name
*)))
2064 (defun build-dynamics ()
2066 (dolist (putative-pair (def :dynamic-variables
))
2067 (if (atom putative-pair
)
2068 (push (list putative-pair nil
) result
)
2069 (push putative-pair result
)))
2072 (defun parse-test-body (test-body)
2073 (let ((test-name nil
)
2077 (test-number (1+ (testsuite-test-count *current-suite-class-name
*)))
2078 (name-supplied? nil
))
2079 ;; parse out any documentation
2080 (loop for form in test-body do
2081 (if (and (consp form
)
2082 (keywordp (first form
))
2083 (eq :documentation
(first form
)))
2084 (setf documentation
(second form
))
2085 (push form parsed-body
)))
2086 (setf test-body
(nreverse parsed-body
))
2087 (setf test-name
(first test-body
))
2088 (cond ((symbolp test-name
)
2090 (intern (format nil
"~A" test-name
))
2091 body
(rest test-body
)
2093 ((and (test-code->name-table
*current-suite-class-name
*)
2096 (test-code->name-table
*current-suite-class-name
*))))
2097 (setf body test-body
))
2100 (intern (format nil
"TEST-~A"
2103 (values test-name body documentation name-supplied?
)))
2105 (defun build-test-class ()
2106 ;; for now, we don't generate code from :class-def code-blocks
2107 ;; they are executed only for effect.
2108 (loop for
(nil . block
) in
*code-blocks
*
2111 (eq (operate-when block
) :class-def
)
2112 (or (not (filter block
))
2113 (funcall (filter block
)))) collect
2114 (funcall (code block
)))
2115 (unless (some (lambda (superclass)
2116 (testsuite-p superclass
))
2117 (def :superclasses
))
2118 (pushnew 'test-mixin
(def :superclasses
)))
2119 ;; build basic class and standard class
2120 `(defclass ,(def :testsuite-name
) (,@(def :superclasses
))
2122 ,@(when (def :documentation
)
2123 `((:documentation
,(def :documentation
))))
2125 :test-slot-names
',(def :slot-names
)
2126 ,@(def :default-initargs
))))
2128 (defun parse-test-slots (slot-specs)
2129 (loop for spec in slot-specs collect
2130 (let ((parsed-spec spec
))
2131 (if (member :initform parsed-spec
)
2132 (let ((pos (position :initform parsed-spec
)))
2133 (append (subseq parsed-spec
0 pos
)
2134 (subseq parsed-spec
(+ pos
2))))
2137 (defmethod testsuite-p ((classname symbol
))
2138 (let ((class (find-class classname nil
)))
2141 (typep (allocate-instance class
) 'test-mixin
)
2143 (error (c) (declare (ignore c
)) (values nil
)))))
2145 (defmethod testsuite-p ((object standard-object
))
2146 (testsuite-p (class-name (class-of object
))))
2148 (defmethod testsuite-p ((class standard-class
))
2149 (testsuite-p (class-name class
)))
2151 (defmethod testsuite-methods ((classname symbol
))
2152 (testsuite-tests classname
))
2154 (defmethod testsuite-methods ((test test-mixin
))
2155 (testsuite-methods (class-name (class-of test
))))
2157 (defmethod testsuite-methods ((test standard-class
))
2158 (testsuite-methods (class-name test
)))
2161 ;; some handy properties
2162 (defclass-property test-slots
)
2163 (defclass-property test-code-
>name-table
)
2164 (defclass-property test-name-
>code-table
)
2165 (defclass-property test-case-documentation
)
2166 (defclass-property testsuite-prototype
)
2167 (defclass-property testsuite-tests
)
2168 (defclass-property testsuite-dynamic-variables
)
2170 ;;?? issue 27: break encapsulation of code blocks
2171 (defclass-property testsuite-function-specs
)
2173 (defun empty-test-tables (test-name)
2174 (when (find-class test-name nil
)
2175 (setf (test-code->name-table test-name
)
2176 (make-hash-table :test
#'equal
)
2177 (test-name->code-table test-name
)
2178 (make-hash-table :test
#'equal
)
2179 (test-case-documentation test-name
)
2180 (make-hash-table :test
#'equal
))))
2183 (define-condition timeout-error
(error)
2185 (:report
(lambda (c s
)
2186 (declare (ignore c
))
2187 (format s
"Process timeout"))))
2189 (defmacro with-timeout
((seconds) &body body
)
2191 `(mp:with-timeout
(,seconds
(error 'timeout-error
))
2194 `(mp:with-timeout
(,seconds
) ,@body
)
2197 (sb-ext:with-timeout
,seconds
,@body
)
2198 (sb-ext::timeout
(c)
2199 (cerror "Timeout" 'timeout-error
)))
2200 #+(or digitool openmcl
)
2201 (let ((checker-process (format nil
"Checker ~S" (gensym)))
2202 (waiting-process (format nil
"Waiter ~S" (gensym)))
2205 `(let* ((,result nil
)
2206 (,process
(ccl:process-run-function
2209 (setf ,result
(progn ,@body
))))))
2210 (ccl:process-wait-with-timeout
2212 (* ,seconds
#+openmcl ccl
:*ticks-per-second
* #+digitool
60)
2214 (not (ccl::process-active-p
,process
))))
2215 (when (ccl::process-active-p
,process
)
2216 (ccl:process-kill
,process
)
2217 (cerror "Timeout" 'timeout-error
))
2219 #-
(or allegro cmu sb-thread openmcl digitool
)
2222 (defvar *test-maximum-time
* 2
2223 "Maximum number of seconds a process test is allowed to run before we give up.")
2225 (pushnew :timeout
*deftest-clauses
*)
2228 :timeout
1 :class-def
2229 (lambda () (def :timeout
))
2230 '((setf (def :timeout
) (cleanup-parsed-parameter value
)))
2232 (unless (some (lambda (super)
2233 (member (find-class 'process-test-mixin
)
2234 (superclasses super
)))
2235 (def :superclasses
))
2236 (pushnew 'process-test-mixin
(def :superclasses
)))
2237 (push (def :timeout
) (def :default-initargs
))
2238 (push :maximum-time
(def :default-initargs
))
2241 (defclass process-test-mixin
()
2242 ((maximum-time :initform
*test-maximum-time
*
2243 :accessor maximum-time
2244 :initarg
:maximum-time
)))
2246 (defclass test-timeout-failure
(test-failure)
2247 ((test-problem-kind :initform
"Timeout" :allocation
:class
)))
2249 (define-condition test-timeout-condition
(test-condition)
2250 ((maximum-time :initform
*test-maximum-time
*
2251 :accessor maximum-time
2252 :initarg
:maximum-time
))
2253 (:report
(lambda (c s
)
2254 (format s
"Test ran out of time (longer than ~S-second~:P)"
2255 (maximum-time c
)))))
2257 (defmethod do-testing :around
((testsuite process-test-mixin
) result fn
)
2258 (declare (ignore fn
))
2260 (with-timeout ((maximum-time testsuite
))
2264 (declare (ignore c
))
2265 (report-test-problem
2266 'test-timeout-failure result testsuite
(current-method testsuite
)
2267 (make-instance 'test-timeout-condition
2268 :maximum-time
(maximum-time testsuite
))))))
2272 (defmethod find-testsuite ((suite symbol
))
2273 (or (testsuite-p suite
)
2274 (find-testsuite (symbol-name suite
))))
2276 (defmethod find-testsuite ((suite-name string
))
2278 (possibilities (remove-duplicates
2279 (loop for p in
(list-all-packages)
2280 when
(and (setf temp
(find-symbol suite-name p
))
2281 (find-class temp nil
)
2282 (subtypep temp
'test-mixin
)) collect
2284 (cond ((null possibilities
)
2285 (error 'test-class-not-defined
:test-class-name suite-name
))
2286 ((= (length possibilities
) 1)
2287 (first possibilities
))
2289 (error "There are several test suites named ~s: they are ~{~s~^, ~}"
2290 suite-name possibilities
)))))
2292 (defun last-test-status ()
2293 (cond ((typep *test-result
* 'test-result
)
2294 (cond ((and (null (errors *test-result
*))
2295 (null (failures *test-result
*)))
2297 ((and (errors *test-result
*)
2298 (failures *test-result
*))
2299 :errors-and-failures
)
2300 ((errors *test-result
*)
2302 ((failures *test-result
*)
2307 (defun suite-tested-p (suite &key
(result *test-result
*))
2309 (typep *test-result
* 'test-result
)
2310 (slot-exists-p result
'suites-run
)
2311 (slot-boundp result
'suites-run
)
2312 (consp (suites-run result
))
2313 (find suite
(suites-run result
))))
2315 (defun unique-filename (pathname)
2316 (let ((date-part (date-stamp)))
2322 :name
(format nil
"~a-~a-~d"
2323 (pathname-name pathname
)
2326 (unless (probe-file name
)
2327 (return-from unique-filename name
)))
2328 (error "Unable to find unique pathname for ~a" pathname
)))
2330 (defun date-stamp (&key
(datetime (get-universal-time)) (include-time? nil
))
2331 (multiple-value-bind
2332 (second minute hour day month year day-of-the-week
)
2333 (decode-universal-time datetime
)
2334 (declare (ignore day-of-the-week
))
2335 (let ((date-part (format nil
"~d-~2,'0d-~2,'0d" year month day
))
2336 (time-part (and include-time?
2337 (list (format nil
"-~2,'0d-~2,'0d-~2,'0d"
2338 hour minute second
)))))
2339 (apply 'concatenate
'string date-part time-part
))))
2342 (date-stamp :include-time? t
)
2344 ;;?? might be "cleaner" with a macrolet (cf. lift-result)
2345 (defun lift-property (name)
2346 (when *current-test
*
2347 (getf (getf (test-data *current-test
*) :properties
) name
)))
2350 (setf (getf (getf (third (first (tests-run *test-result
*))) :properties
) :foo
)
2353 (defun (setf lift-property
) (value name
)
2354 (when *current-test
*
2355 (setf (getf (getf (test-data *current-test
*) :properties
) name
) value
)))
