1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
|
;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; ID: $Id$
;;;; Purpose: Test fixtures for XLUnit
;;;;
;;;; *************************************************************************
(in-package #:xlunit)
(defclass test-fixture ()
((test-fn
:initarg :test-fn :reader test-fn :initform nil
:documentation
"A function designator which will be applied to this instance
to perform that test-case.")
(test-name
:initarg :test-name :reader test-name
:documentation
"The name of this test-case, used in reports.")
(test-description
:initarg :description :reader description
:documentation
"Short description of this test-case, uses in reports"))
(:documentation
"Base class for test-fixtures. Test-cases are instances of test-fixtures."))
(defgeneric setup (test)
(:documentation
"Method called before performing a test, should set up the
environment the test-case needs to operate in."))
(defmethod setup ((test test-fixture))
t)
(defgeneric teardown (test)
(:documentation
"Method called after performing a test. Should reverse everything
that the setup method did for this instance."))
(defmethod teardown ((test test-fixture))
t)
(defmacro handler-case-if (test form &body cases)
`(if ,test
(handler-case
,form
,@cases)
,form))
(defmacro unwind-protect-if (test protected cleanup)
`(if ,test
(unwind-protect
,protected
,cleanup)
(progn ,protected ,cleanup)))
(defmethod run-test ((test test-fixture)
&key (result (make-instance 'test-result))
(handle-errors t))
"Perform the test represented by the given test-case or test-suite.
Returns a test-result object."
(incf (test-count result))
(with-slots (failures errors) result
(unwind-protect-if handle-errors
(handler-case-if handle-errors
(let ((res (progn (setup test)
(funcall (test-fn test) test))))
(when (typep res 'test-failure-condition)
(push (make-test-failure test res) failures)))
(test-failure-condition (failure)
(push (make-test-failure test failure) failures))
(error (err)
(push (make-test-failure test err) errors)))
(if handle-errors
(handler-case
(teardown test)
(error (err)
(push (make-test-failure test err) errors)))
(teardown test))))
result)
(defun make-test (fixture name &key test-fn test-suite description)
"Create a test-case which is an instance of FIXTURE. TEST-FN is
the method that will be invoked when perfoming this test, and can be a
symbol or a lambda taking a single argument, the test-fixture
instance. DESCRIPTION is obviously what it says it is."
(let ((newtest (make-instance fixture
:test-name (etypecase name
(symbol
(string-downcase (symbol-name name)))
(string
name))
:test-fn
(if(and (symbolp name) (null test-fn))
name
test-fn)
:description description)))
(when test-suite (add-test newtest test-suite))
newtest))
|
