File: clunit.lisp

package info (click to toggle)
cl-unit 1.3.1-2
  • links: PTS
  • area: main
  • in suites: etch, etch-m68k, sarge
  • size: 160 kB
  • ctags: 42
  • sloc: lisp: 259; makefile: 49; sh: 27
file content (383 lines) | stat: -rw-r--r-- 14,341 bytes parent folder | download
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
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
;;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: USER; Base:10 -*-
;;;;
;;;;	Author:	Frank A. Adrian
;;;;
;;;; Release history:
;;;;            20021126 -      Release 1.3
;;;;            20021125 -      Release 1.2a
;;;;		20021124 -	Release 1.2
;;;;		20010605 -	Release 1.1
;;;;		20010527 -	Release 1.0
;;;;
;;;; Modification history:
;;;;            20021126 -      Fixed compilation issues
;;;;            20021125 -      Fixed :nconc-name issue for Corman Lisp
;;;;		20021124 -	Fixed "AND error", switched from test object to structure
;;;;		20010605 -	Added licensing text, compare-fn keyword.
;;;;		20010604 -	Added :input-form and :output-form options,
;;;;					failed-tests function
;;;;		20010524 -	Code readied for public distribution.
;;;;		20010219 -	Added list-* functions.
;;;;		20000614 -	Added input-fn, output-fn.
;;;;		20000520 -	Added categories.
;;;;		20000502 -	Added deftest.
;;;;		20000428 -	Initial Revision.
;;;;
;;;; Copyright (c) 2000-2002.  Frank A. Adrian.  All rights reserved.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
;;;;
;;;; The author also requests that any changes and/or improvents to the
;;;; code be shared with the author for use in subsequent releases.  Author's
;;;; E-mail: fadrian@ancar.org.
;;;;
;;;;

(defpackage :org.ancar.CLUnit
	(:use #:common-lisp)
;Kill the next form in Corman and Franz Lisps because their defpackage :documentation
;option is not present.
#-(or :cormanlisp excl)
	(:documentation
		"This package contains a unit testing environment for Common Lisp.
		All tests are held in the system image.  Each test has a name and
		a category.  All tests in the system can be run, as can all tests
		in a given category.
				
		The tests are specified by a test function that is normally written
		so as to take no input and to return T if the test passes.  Optionally,
		an input function and/or an output function can also be specified.
		If an input function is specified, the test function is applied to
		the return value(s) of the input function.  If the output function
		is specified, then the return value(s) of the test function is
		compared (via #'eql) to the return value(s) of the output function
		to check if the test succeeded.
				
		The package provides several functions and a deftest macro that makes
		specifying a test simple:
			clear-tests: 		Remove all tests from the system.
			remove-test: 		Remove a test from the system by name.
			run-category:		Run all tests from a given category.
			run-all-tests:		Run all the tests in the system.
			list-categories:	List the categories of tests in the system.
			list-tests:			List all of the tests in the system.
			run-named-test:		Run the test of the given name (mainly for
								debugging use after a given test has not
								passed).
			failed-tests:		Return a list of all tests that failed during the
								last run-all-tests or run-category call.
			deftest:			Define a test for the system."))
		 
(in-package :org.ancar.CLUnit)
(provide :org.ancar.CLUnit)

(defconstant *not-categorized* "*UNCATEGORIZED*")
(defun t-func () t)
(defun nil-func () nil)`
(defun equal-func (x y) (funcall (symbol-function 'equal) x y))

(defun print-test (test str depth)
  (declare (ignore depth))
	(print-unreadable-object (test str :type t :identity t)
		(format str "~A/~A" (descr test) (category test))))

(defstruct (test (:conc-name nil) (:print-function print-test))            
	
	"Test holds information that enables test to be located and run.
                Slots:
                        descr:          Test name.
                        category:       Category test belongs to.
                        test-fn:        Function run for test - by default, a zero-input,
                                                boolean output function. T means the test succeeded.
                        compare-fn:     Function that compares test function output to the
                                                expected output.  Takes 2 lists of values.
                        input-fn:       Function that provides input to the test.  When this
                                                item is used, test-fn is applied to the values returned
                                                by this function.
                        output-fn:      Function that provides data that the output of test-fn
                                                is compared against."
	descr (category *not-categorized*) test-fn compare-fn input-fn output-fn)


(defvar *all-tests* nil
	"Currently, this is a simple list of tests.  If the number of tests
	starts becoming too large, this should probably turn into a hash-table
	of tests hashed on category name.")

(defun clear-tests ()
	"Remove all tests from the system."
	(setf *all-tests* nil))

(defun remove-test (test-name)
	"Remove the test with the given name."
	;(format t "In remove-test~%")
	(setf *all-tests*
		(delete-if #'(lambda (i) (string-equal (descr i) test-name)) *all-tests*)))

(defun run-unprotected (test)
	"Run a test.  No protection against errors."
	(let* ((input-fn (input-fn test))
		  (output-fn (output-fn test))
		  (test-fn (test-fn test))
		  (has-specified-input-fn input-fn))
		
		(unless input-fn (setf input-fn #'nil-func))
		(unless output-fn (setf output-fn #'t-func))
		(let ((test-input (multiple-value-list (funcall input-fn))))
			;(format t "~&Input: ~A~%" test-input)
			(let ((vals (multiple-value-list 
							(if has-specified-input-fn
								(apply test-fn test-input)
								(funcall test-fn))))
				  (tvals (multiple-value-list (funcall output-fn))))
				;(format t "~&Test output: ~A~%Expected output: ~A~%"
				;	vals tvals)
				(funcall (compare-fn test) vals tvals)))))

(defun run-protected (test)
	"Protect the test while running with ignore-errors."
	(let ((vals (multiple-value-list (ignore-errors (run-unprotected test)))))
		;(format t "~&vals: ~A~%" vals)
		(unless (eq (car vals) t)
			(if (cadr vals)
				(format t "~&~A occurred in test ~S~%"
					(cadr vals) (descr test))
				(format t "~&Output did not match expected output in test ~S~%"
					(descr test))))
		vals))

(defun test-or-tests (count)
	"This is for Corman Lisp which does not handle ~[ quite correctly."
	(if (eq count 1) "test" "tests"))

(defvar *failed-tests* nil
	"Holds the set of failed tests from last test run.")

(defun failed-tests ()
	"Return the set of tests that failed during the last test run"
	*failed-tests*)
	
(defun run-tests (tests)
	"Run the set of tests passed in."
	(let ((passed-tests nil)
		  (failed-tests nil))
		(loop for test in tests do
			;(format t "~&Running test: ~A~%" test)
			(let ((test-result (run-protected test)))
				(if (eq (car test-result) t)
					(push test passed-tests)
					(push test failed-tests))))
		(setf *failed-tests* failed-tests)
;		(format t "~&Passed tests: ~A; failed tests: ~A.~%"
;			passed-tests failed-tests)
		(let ((passed-count (length passed-tests))
			  (failed-count (length failed-tests)))
;			(format t "~&Passed count: ~A; failed count: ~A~%"
;				passed-count failed-count)
;			(format t "~&~A ~[tests~;test~:;tests~] run; ~A ~[tests~;test~:;tests~] passed; ~A ~[tests~;test~:;tests~] failed.~%"
;				(+ passed-count failed-count) (+ passed-count failed-count)
;				passed-count passed-count failed-count failed-count)
			(format t "~&~A ~A run; ~A ~A passed; ~A ~A failed.~%"
				(+ passed-count failed-count) (test-or-tests (+ passed-count failed-count))
				passed-count (test-or-tests passed-count)
				failed-count (test-or-tests failed-count))
		(values (null failed-tests) failed-count passed-count))))

(defun filter-tests (category)
	"Filter tests by category."
	(remove-if #'(lambda (test) ;(format t "~&~A~A~%" category (category test))
		(not (string-equal category (category test))))
		*all-tests*))

(defun run-category (category)
	"Run all the tests in a given category."
	(run-tests (filter-tests category)))

(defun run-all-tests ()
	"Run all tests in the system."
	(run-tests *all-tests*))

(defmacro form-to-fn (form)
	"Return a function that will return the form when evaluated.
	Will be used when we add input-form and output-form parameters to
	deftest."
	`#'(lambda () ,form))

(defmacro deftest (description &key	category
					test-fn
					(input-fn nil input-fn-present)
					(output-fn nil output-fn-present)
					(input-form nil input-form-present)
					(output-form nil output-form-present)
					compare-fn)
	
	"Use of :input-fn and :output-fn keywords override use of :input-form and
	:output-form keywords respectively."
	
	(let ((mia-args-gen (gensym))
		  (cat-gen (gensym))
                  (inst-gen (gensym))
		  (ifmfn `#'(lambda () ,input-form))
		  (ofmfn `#'(lambda () ,output-form))
                  (cf-gen (gensym))
                  (tf-gen (gensym)))
		`(let (,mia-args-gen
			   (,cat-gen ,category)
                           (,cf-gen ,compare-fn)
                           (,tf-gen ,test-fn))
			(push :descr ,mia-args-gen) (push ,description ,mia-args-gen)
			(when ,cat-gen
				(push :category ,mia-args-gen) (push ,cat-gen ,mia-args-gen))
			(push :compare-fn ,mia-args-gen) (push (if ,cf-gen ,cf-gen #'equal) ,mia-args-gen)
			(push :test-fn ,mia-args-gen) (push (if ,tf-gen ,tf-gen #'t-func) ,mia-args-gen)
			(when (and ,output-form-present (not ,output-fn-present))
				(push :output-fn ,mia-args-gen) (push ,ofmfn ,mia-args-gen))				
			(when ,output-fn-present
				(push :output-fn ,mia-args-gen) (push ,output-fn ,mia-args-gen))
			(when (and ,input-form-present (not ,input-fn-present))
				(push :input-fn ,mia-args-gen) (push ,ifmfn ,mia-args-gen))				
			(when ,input-fn-present
				(push :input-fn ,mia-args-gen) (push ,input-fn ,mia-args-gen))
			(let ((,inst-gen (apply #'make-test (nreverse ,mia-args-gen))))
                          (remove-test (descr ,inst-gen))
                          (push ,inst-gen *all-tests*)))))

(defun list-categories ()
	"List all of the categories in the system."
	(let (cats)
		(loop for test in *all-tests* doing
			(setf cats (adjoin (category test) cats :test #'string-equal)))
		cats))

(defun list-tests (&optional category)
	"List the tets in the system / category."
	(let ((tests (if category (filter-tests category) *all-tests*)))
		(loop for test in tests collecting
			(concatenate 'string (descr test) "/" (category test)))))

(defun run-named-test (name &optional protected)
	"Run the given test in either protected or unprotected mode."
	(let ((test (find name *all-tests* :key #'descr :test #'string-equal)))
		(when test
			(if protected
				(run-protected test)
				(run-unprotected test)))))

(export '(
		run-category
		run-all-tests
		clear-tests
		remove-test
		deftest
		list-categories
		list-tests
		run-named-test
		failed-tests
		;with-supressed-summary
		))

(in-package "COMMON-LISP-USER")
(use-package :org.ancar.CLUnit)

;;;
;;; Self test...
;;;

;; tests basic test definition
(load-time-value (progn 

(deftest "test1" :category "CLUnit-pass1"
	:test-fn #'(lambda () (eq (car '(a)) 'a)))

;; tests input-fn
(deftest "test-2" :category "CLUnit-pass1"
	:input-fn #'(lambda () '(a))
	:test-fn #'(lambda (x) (eq (car x) 'a)))

;; tests output-fn
(deftest "test-3" :category "CLUnit-pass1"
	:input-fn #'(lambda () '(a))
	:output-fn #'(lambda () 'a)
	:test-fn #'(lambda (x) (car x)))

;; tests remove-test, run-category, and multiple-values in test-fn and
;; output-fn
(deftest "meta" :category "CLUnit-meta"
	:input-fn #'(lambda () (remove-test "test1"))
	:test-fn #'(lambda (x) (declare (ignore x)) (run-category "CLUnit-pass1"))
	:output-fn #'(lambda () (values t 0 2)))

;; tests multiple values from input-fn to test-fn
(deftest "test1" :category "CLUnit-pass2"
	:input-fn #'(lambda () (values 'a '(b)))
	:test-fn #'cons
	:output-fn #'(lambda () '(a b)))

;;check error trapping
(deftest "meta2" :category "CLUnit-meta"
	:input-fn
		#'(lambda () (deftest "Error test" :category "CLUnit-pass3"
						:test-fn #'(lambda ()
							(remove-test "Error test") (error "Dummy error"))))
	:test-fn #'(lambda (x) (declare (ignore x)) (run-category "CLUnit-pass3"))
	:output-fn #'(lambda () (values nil 1 0)))

;;check input-form
(deftest "testx" :category "CLUnit"
	:input-form '(a b c)
	:test-fn #'car
	:output-fn #'(lambda () 'a))

;;check output form
(deftest "testx2" :category "CLUnit"
	:input-form '(a b c)
	:test-fn #'car
	:output-form 'a)

;;check multiple input-forms
(deftest "testx3" :category "CLUnit"
	:input-form (values '(1 2 3) '(10 20 30))
	:test-fn #'(lambda (&rest lists) (car lists))
	:output-fn #'(lambda () '(1 2 3)))

;;check multiple output-forms
(deftest "testx4" :category "CLUnit"
	:input-form (values '(1 2 3) '(10 20 30))
	:test-fn #'(lambda (&rest lists) (apply #'values lists))
	:output-fn #'(lambda () (values '(1 2 3) '(10 20 30))))

;;check failed-tests
(deftest "meta5" :category "CLUnit-meta"
	:input-fn
		#'(lambda () (deftest "Error test" :category "CLUnit-pass4"
						:test-fn #'(lambda ()
							(remove-test "Error test") (error "Dummy error"))))
	:test-fn #'(lambda (x) (declare (ignore x))
				(run-category "CLUnit-pass4")
				(values (length (failed-tests)) (org.ancar.CLUnit::descr (car (failed-tests)))))
	:output-fn #'(lambda () (values 1 "Error test")))

(deftest "Test compare-fn"
	:test-fn #'(lambda () "abc")
	:output-form "abc"
	:compare-fn #'(lambda (rlist1 rlist2)
					(not (null (reduce #'(lambda (x y) (and x y))
                                                (mapcar #'string-equal rlist1 rlist2) :initial-value t)))))

;;; run self test	
(when (run-all-tests)
	(format t "~&CLUnit self-test passed.~%")
	(clear-tests)
	(values))))