/[cparse]/cparse/cl-unit.lisp
ViewVC logotype

Contents of /cparse/cl-unit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (show annotations) (vendor branch)
Sun Mar 3 02:11:37 2002 UTC (12 years, 1 month ago) by clynbech
Branch: MAIN, CPARSE
CVS Tags: CPARSE_0_2_4, HEAD
Changes since 1.1: +0 -0 lines
Import of CPARSE upstream version 0.2.4
1 ;;;
2 ;;; Copyright (c) 2001 Timothy Moore
3 ;;; All rights reserved.
4 ;;;
5 ;;; Redistribution and use in source and binary forms, with or without
6 ;;; modification, are permitted provided that the following conditions
7 ;;; are met:
8 ;;; 1. Redistributions of source code must retain the above copyright
9 ;;; notice, this list of conditions and the following disclaimer.
10 ;;; 2. Redistributions in binary form must reproduce the above copyright
11 ;;; notice, this list of conditions and the following disclaimer in the
12 ;;; documentation and/or other materials provided with the distribution.
13 ;;; 3. The name of the author may not be used to endorse or promote products
14 ;;; derived from this software without specific prior written permission.
15 ;;;
16 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
17 ;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
18 ;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
19 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
20 ;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
21 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
22 ;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
23 ;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
24 ;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
25 ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
26 ;;; SUCH DAMAGE.
27
28 (defpackage "CL-UNIT"
29 (:use "COMMON-LISP")
30 (:export "UNIT-TEST-SUITE"
31 "ADD-TEST" "DEFTEST" "RUN-TESTS" "ERROR-STREAM"
32 "LOG-STREAM" "UNIT-TEST" "TESTS" "RUN-TESTS" "CLEAN-UP"
33 "RUN-ONE-TEST" "RUN-TEST"))
34
35 (in-package "CL-UNIT")
36
37 (defclass unit-test-suite ()
38 ((error-stream :accessor error-stream :initarg :error-stream
39 :initform *standard-output*)
40 (log-stream :accessor log-stream :initarg :log-stream
41 :initform *standard-output*)
42 (tests :accessor tests :initform nil)
43 (debug-on-error :accessor debug-on-error :initarg :debug-on-error
44 :initform nil)))
45
46 ;;; Clean up test state
47
48 (defgeneric clean-up (test))
49
50 (defmethod clean-up ((test unit-test-suite))
51 nil)
52
53 (defgeneric add-test (test-obj name func))
54
55 (defmethod add-test ((test-obj unit-test-suite) name func)
56 (let ((existing (assoc name (tests test-obj) :test #'equal)))
57 (if existing
58 (setf (cdr existing) func)
59 (setf (tests test-obj) (nconc (tests test-obj) `((,name . ,func)))))))
60
61
62 (defmacro deftest ((name suite) (test-suite) &body body)
63 (let* ((lambda-args-body `((,test-suite)
64 (let ((error-stream (error-stream ,test-suite))
65 (log-stream (log-stream ,test-suite)))
66 (declare (ignorable error-stream log-stream))
67 ,@body)))
68 (defun-form (when (symbolp name)
69 `((defun ,name ,@lambda-args-body))))
70 (fun-object (if (symbolp name)
71 `#',name
72 `#'(lambda ,@lambda-args-body))))
73 `(eval-when (load eval)
74 ,@defun-form
75 (add-test ,suite ',name ,fun-object))))
76
77 (defgeneric run-tests (test-suite &key debug-on-error verbose))
78
79 (defmethod run-tests ((suite unit-test-suite) &key debug-on-error verbose)
80 (let ((err-stream (error-stream suite)))
81 (setf (debug-on-error suite) debug-on-error)
82 (let ((failures 0)
83 (total 0))
84 (loop for (name . func) in (tests suite)
85 do (progn
86 (incf total)
87 (multiple-value-bind (test-val status)
88 (run-one-test suite name func)
89 (format t "~A ~:[failed~;succeeded~]: ~S~%"
90 name status test-val)
91 (unless status
92 (incf failures)))))
93 (format err-stream "~D/~D tests failed.~%" failures total))))
94
95 (defgeneric run-one-test (suite name func))
96
97 (defmethod run-one-test ((suite unit-test-suite) name func)
98 (if (debug-on-error suite)
99 (restart-case (values (funcall func suite) t)
100 (continue-tests ()
101 :report "Continue with tests"
102 (values nil nil)))
103 (handler-case (values (funcall func suite) t)
104 (error (condition)
105 (format (error-stream suite) "~&Test ~A: failed:~A~%"
106 name condition)
107 (values nil nil)))))
108
109 (defgeneric run-test (name suite &key))
110
111 (defmethod run-test (name (suite unit-test-suite)
112 &key initargs)
113 (let ((err-stream (error-stream suite))
114 (func (cdr (assoc name (tests suite) :test #'equal))))
115 (unless func
116 (format err-stream "No test named ~A. Eit.~%" name)
117 (return-from run-test nil))
118 (setf (debug-on-error suite) t)
119 (multiple-value-bind (test-val status)
120 (run-one-test suite name func)
121 (declare (ignore test-val))
122 (unless status
123 (format err-stream "Test ~A failed." name)))))
124
125
126
127

  ViewVC Help
Powered by ViewVC 1.1.5