1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; ID: $Id: test-case.lisp,v 1.2 2003/08/04 16:42:27 kevin Exp $
6 ;;;; Purpose: Test fixtures for XLUnit
8 ;;;; *************************************************************************
16 (defclass test-case (test)
17 ((existing-suites :initform nil :accessor existing-suites
20 :initarg :method-body :accessor method-body :initform nil
22 "A function designator which will be applied to this instance
23 to perform that test-case.")
24 (name :initarg :name :reader name
25 :documentation "The name of this test-case, used in reports.")
26 (description :initarg :description :reader description
28 "Short description of this test-case, uses in reports")
29 (suite :initform nil :accessor suite :initarg :suite))
31 "Base class for test-cases."))
33 (defmethod initialize-instance :after ((ob test-case) &rest initargs)
34 (declare (ignore initargs))
35 (if (null (existing-suites ob))
36 (setf (existing-suites ob) (make-hash-table))) ;;hash singleton
37 (unless (gethash (type-of ob) (existing-suites ob))
38 (setf (gethash (type-of ob) (existing-suites ob))
39 (make-instance 'test-suite))) ;;specifi suite singleton
40 (setf (suite ob) (gethash (type-of ob) (existing-suites ob))))
43 (defgeneric set-up (test)
45 "Method called before performing a test, should set up the
46 environment the test-case needs to operate in."))
48 (defmethod set-up ((test test-case))
51 (defgeneric tear-down (test)
53 "Method called after performing a test. Should reverse everything
54 that the setup method did for this instance."))
56 (defmethod tear-down ((test test-case))
59 (defmethod run ((ob test-case))
60 (run-on-test-result ob (make-instance 'test-results)))
64 (defmethod run-on-test-result ((test test-case)
65 &key (result (make-instance 'test-result))
67 (start-test test result)
68 (run-protected test result :handle-errors handle-errors)
69 (end-test test result))
71 (defmethod run-base ((test test-case))
77 (defmethod run-test ((test test-case))
78 (funcall (method-body test)))
80 (defmethod run-protected ((test test-case) res &key (handle-errors t))
83 (assertion-failed (condition)
84 (add-failure res test condition))
85 (serious-condition (condition)
86 (add-error res test condition)))
90 (defmacro handler-case-if (test form &body cases)
97 (defmacro unwind-protect-if (test protected cleanup)
102 (progn ,protected ,cleanup)))
105 (defmethod run-test ((test test-case)
106 &key (result (make-instance 'test-result))
108 "Perform the test represented by the given test-case or test-suite.
109 Returns a test-result object."
110 (incf (run-count result))
111 (with-slots (failures errors) result
112 (unwind-protect-if handle-errors
113 (handler-case-if handle-errors
114 (let ((res (progn (setup test)
115 (funcall (method-body test) test))))
116 (when (typep res 'test-failure-condition)
117 (push (make-test-failure test res) failures)))
118 (test-failure-condition (failure)
119 (push (make-test-failure test failure) failures))
121 (push (make-test-failure test err) errors)))
127 (push (make-test-failure test err) errors)))
132 (defun make-test (fixture name &key method-body test-suite description)
133 "Create a test-case which is an instance of FIXTURE. METHOD-BODY is
134 the method that will be invoked when perfoming this test, and can be a
135 symbol or a lambda taking a single argument, the test-case
136 instance. DESCRIPTION is obviously what it says it is."
137 (let ((newtest (make-instance fixture
138 :name (etypecase name
140 (string-downcase (symbol-name name)))
144 (if (and (symbolp name) (null method-body))
147 :description description)))
148 (when test-suite (add-test newtest test-suite))