1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; ID: $Id: suite.lisp,v 1.5 2003/08/04 17:04:49 kevin Exp $
6 ;;;; Purpose: Suite functions for XLUnit
8 ;;;; *************************************************************************
12 (defclass test-suite ()
13 ((name :initform "" :initarg :name :reader test-suite-name)
14 (tests :initarg :tests :accessor tests :initform nil)
15 (description :initarg :description :reader description
16 :initform "No description.")))
18 (defmacro get-suite (class-name)
19 `(suite (make-instance ',class-name)))
22 (defmethod setup-testsuite-named (name)
23 (declare (ignore name))
26 (defmethod teardown-testsuite-named (name)
27 (declare (ignore name))
30 (defmethod run-on-test ((suite test-suite)
31 &key (result (make-instance 'test-results))
33 (setup-testsuite-named (slot-value suite 'name))
34 (dolist (test (tests suite))
35 (run-on-test test :result result :handle-errors handle-errors))
36 (teardown-testsuite-named (slot-value suite 'name))
40 (defmethod add-test ((ob test-suite) (new-test test))
42 (delete-if #'(lambda (existing-tests-or-suite)
43 (cond ((typep existing-tests-or-suite 'test-suite)
44 (eq existing-tests-or-suite new-test))
45 ((typep existing-tests-or-suite 'test-case)
46 (eql (name existing-tests-or-suite)
49 (setf (tests ob) (append (tests ob) (list new-test))))
52 (defmethod remove-test ((test test-case) (suite test-suite))
53 (remhash (name test) (tests-hash suite)))
55 (defmethod remove-test ((test test-suite) (suite test-suite))
56 (remhash (test-suite-name test) (tests-hash suite)))
58 (defmethod named ((name string) (suite test-suite))
59 (gethash name (tests-hash suite)))
64 (defun make-test-suite-for-fixture
67 (format nil "Automatic for ~A"
68 (if (slot-boundp fixture 'name)
72 (let ((suite (make-instance 'test-suite
74 :description description))
75 (fns (find-test-generic-functions fixture)))
77 (make-test (class-name (class-of fixture)) fn
81 (defun find-test-generic-functions (instance)
82 "Return a list of symbols for generic functions specialized on the
83 class of an instance and whose name begins with the string 'test-'.
84 This is used to dynamically generate a list of tests for a fixture."
86 (package (symbol-package (class-name (class-of instance)))))
87 (do-symbols (s package)
88 (when (and (> (length (symbol-name s)) 5)
89 (string-equal "test-" (subseq (symbol-name s) 0 5))
91 (typep (symbol-function s) 'generic-function)
93 (plusp (length (compute-applicable-methods
94 (ensure-generic-function s)
100 ;----------------------------------------------------------------------
101 ; macro def-test-method
103 ; Creates the representation of a test method (included within a
104 ; test-case object) and add it to the corresponding suite class.
105 ; => clos version of the pluggable selector pattern
107 ; use: (def-test-method test-assert-false (clos-unit-test)
108 ; (assert-true (eql (+ 1 2) 4) "comment"))
110 ; new: it calls the textui-test-run function during eval, so to
111 ; allow the usual lisp-like incremental developing and test.
112 ;----------------------------------------------------------------------
114 (defmacro def-test-method (method-name class-name &body method-body)
115 `(let ((,(caar class-name)
116 (make-instance ',(cadar class-name)
117 :name ',method-name)))
118 (setf (method-body ,(caar class-name))
119 #'(lambda() ,@method-body))
120 (add-test (suite ,(caar class-name)) ,(caar class-name))
121 (textui-test-run ,(caar class-name))))