1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: fixture.lisp
6 ;;;; Purpose: eXtreme Lisp Test Suite
7 ;;;; Authors: Kevin Rosenberg and Craig Brozefsky
9 ;;;; $Id: fixture.lisp,v 1.1 2003/08/04 12:01:54 kevin Exp $
10 ;;;; *************************************************************************
15 (defclass test-fixture ()
17 :initarg :test-thunk :reader test-thunk
18 :initform 'perform-test
20 "A thunk or symbol which will be applied to this instance, a
21 test-case, to perform that test-case. Defaults to 'perform-test")
26 "The name of this test-case, used in reports.")
31 "Short description of this test-case, uses in reports"))
33 "Base class for test-fixtures. Test-cases are instances of test-fixtures."))
35 (defgeneric setup (test)
37 "Method called before performing a test, should set up the
38 environment the test-case needs to operate in."))
40 (defmethod setup ((test test-fixture))
43 (defgeneric teardown (test)
45 "Method called after performing a test. Should reverse everything
46 that the setup method did for this instance."))
48 (defmethod teardown ((test test-fixture))
52 (defmacro handler-case-if (test form &body cases)
59 (defmacro unwind-protect-if (test protected cleanup)
64 (progn ,protected ,cleanup)))
67 (defmethod run-test ((test test-fixture)
68 &key (result (make-instance 'test-result))
70 "Perform the test represented by the given test-case or test-suite.
71 Returns one or more test-result objects, one for each test-case
73 (incf (test-count result))
74 (with-slots (failures errors) result
75 (unwind-protect-if handle-errors
76 (handler-case-if handle-errors
77 (let ((res (progn (setup test)
78 (funcall (test-thunk test) test))))
79 (if (typep res 'test-failure-condition)
80 (push (make-instance 'test-failure
82 :thrown-condition res)
84 (test-failure-condition (failure)
85 (push (make-instance 'test-failure
87 :thrown-condition failure)
90 (push (make-instance 'test-failure
92 :thrown-condition err)
99 (make-instance 'test-failure
100 :failed-test test :thrown-condition err)
106 (defun make-test (fixture name &key test-thunk test-suite description)
107 "Create a test-case which is an instance of FIXTURE. TEST-THUNK is
108 the method that will be invoked when perfoming this test, and can be a
109 symbol or a lambda taking a single argument, the test-fixture
110 instance. DESCRIPTION is obviously what it says it is."
111 (let ((newtest (make-instance fixture
112 :test-name (etypecase name
114 (string-downcase (symbol-name name)))
118 (if(and (symbolp name) (null test-thunk))
121 :description description)))
122 (if test-suite (add-test newtest test-suite))