1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Suite functions for XLUnit
7 ;;;; Authors: Kevin Rosenberg and Craig Brozefsky
9 ;;;; $Id: suite.lisp,v 1.1 2003/08/04 12:01:54 kevin Exp $
10 ;;;; *************************************************************************
14 (defclass test-suite ()
15 ((name :initarg :name :reader test-suite-name)
16 (tests :initarg :tests :accessor tests-hash
17 :initform (make-hash-table :test 'equal))
18 (description :initarg :description :reader description
19 :initform "No description.")))
22 (defmethod setup-testsuite-named (name)
23 (declare (ignore name))
26 (defmethod teardown-testsuite-named (name)
27 (declare (ignore name))
30 (defmethod run-test ((suite test-suite)
31 &key (result (make-instance 'test-result))
33 (setup-testsuite-named (slot-value suite 'name))
34 (dolist (test (tests suite))
35 (run-test test :result result :handle-errors handle-errors))
36 (teardown-testsuite-named (slot-value suite 'name))
39 (defmethod tests ((suite test-suite))
41 (maphash #'(lambda (k v)
43 (setf tlist (cons v tlist)))
48 (defun make-test-suite (name-or-fixture &optional description testspecs)
49 "Returns a new test-suite based on a name and TESTSPECS or a fixture
51 (etypecase name-or-fixture
53 (make-test-suite-for-fixture (make-instance name-or-fixture)))
55 (let ((suite (make-instance 'test-suite :name name-or-fixture
56 :description description)))
57 (dolist (testspec testspecs)
58 (add-test (apply #'make-test testspec) suite))
62 (defmethod add-test ((test test-fixture) (suite test-suite))
63 (setf (gethash (test-name test) (tests-hash suite)) test))
65 (defmethod add-test ((test test-suite) (suite test-suite))
66 (setf (gethash (test-suite-name test) (tests-hash suite)) test))
68 (defmethod remove-test ((test test-fixture) (suite test-suite))
69 (remhash (test-name test) (tests-hash suite)))
71 (defmethod remove-test ((test test-suite) (suite test-suite))
72 (remhash (test-suite-name test) (tests-hash suite)))
74 (defmethod test-named ((name string) (suite test-suite))
75 (gethash name (tests-hash suite)))
80 (defun make-test-suite-for-fixture
83 (format nil "Automatic for ~A"
84 (if (slot-boundp fixture 'test-name)
88 (let ((suite (make-instance 'test-suite
90 :description description))
91 (fns (find-test-generic-functions fixture)))
93 (make-test (class-name (class-of fixture)) fn
97 (defun find-test-generic-functions (instance)
98 "Return a list of symbols for generic functions specialized on the
99 class of an instance and whose name begins with the string 'test-'.
100 This is used to dynamically generate a list of tests for a fixture."
102 (package (symbol-package (class-name (class-of instance)))))
103 (do-symbols (s package)
104 (when (and (> (length (symbol-name s)) 5)
105 (string-equal "test-" (subseq (symbol-name s) 0 5))
107 (typep (symbol-function s) 'generic-function)
108 (plusp (length (compute-applicable-methods
109 (ensure-generic-function s)
117 (defmethod text-testrunner ((suite test-suite) &key (stream t)
119 (let* ((start-time (get-internal-real-time))
120 (result (run-test suite :handle-errors handle-errors))
121 (seconds (/ (- (get-internal-real-time) start-time)
122 internal-time-units-per-second)))
123 (result-printer result seconds stream)))