1 ;;;-*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*-
4 Copyright
(c) 2004-
2005 Christopher K. Riesbeck
6 Permission is hereby granted
, free of charge
, to any person obtaining
7 a copy of this software and associated documentation files
(the "Software"),
8 to deal in the Software without restriction
, including without limitation
9 the rights to use
, copy
, modify
, merge
, publish
, distribute
, sublicense
,
10 and
/or sell copies of the Software
, and to permit persons to whom the
11 Software is furnished to do so
, subject to the following conditions
:
13 The above copyright notice and this permission notice shall be included
14 in all copies or substantial portions of the Software.
16 THE SOFTWARE IS PROVIDED
"AS IS", WITHOUT WARRANTY OF ANY KIND
, EXPRESS
17 OR IMPLIED
, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY
,
18 FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
19 THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM
, DAMAGES OR
20 OTHER LIABILITY
, WHETHER IN AN ACTION OF CONTRACT
, TORT OR OTHERWISE
,
21 ARISING FROM
, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
22 OTHER DEALINGS IN THE SOFTWARE.
28 1. Read the documentation at
:
29 https
://github.com
/OdonataResearchLLC
/lisp-unit
/wiki
31 2. Make a file of DEFINE-TEST
's. See exercise-tests.lisp for many
32 examples. If you want
, start your test file with
(REMOVE-TESTS :ALL
)
33 to clear any previously defined tests.
37 4.
(use-package :lisp-unit
)
39 5. Load your code file and your file of tests.
41 6. Test your code with
(RUN-TESTS '(test-name1 test-name2 ...
)) or
42 simply
(RUN-TESTS :ALL
) to run all defined tests.
44 A summary of how many tests passed and failed will be printed.
46 NOTE
: Nothing is compiled until RUN-TESTS is expanded. Redefining
47 functions or even macros does not require reloading any tests.
55 (defpackage :lisp-unit
58 (:export
:*print-summary
*
61 ;; Forms for assertions
72 ;; Functions for managing tests
80 ;; Functions for managing tags
85 ;; Functions for reporting test results
92 (:export
:logically-equal
:set-equal
))
94 (in-package :lisp-unit
)
98 (defparameter *pass
* 0
99 "The number of passed assertions.")
101 (defparameter *fail
* 0
102 "The number of failed assertions.")
106 (defparameter *print-summary
* nil
107 "Print a summary of the pass, fail, and error count if non-nil.")
109 (defparameter *print-failures
* nil
110 "Print failure messages if non-NIL.")
112 (defparameter *print-errors
* nil
113 "Print error messages if non-NIL.")
115 (defparameter *use-debugger
* nil
116 "If not NIL, enter the debugger when an error is encountered in an
119 (defun use-debugger-p (condition)
120 "Debug or ignore errors."
122 ((eq :ask
*use-debugger
*)
123 (y-or-n-p "~A -- debug?" condition
))
126 ;;; Failure control strings
128 (defgeneric print-failure
(type form expected actual extras
)
130 "Report the details of the failure assertion."))
132 (defmethod print-failure :around
(type form expected actual extras
)
133 "Failure header and footer output."
134 (format t
" | Failed Form: ~S" form
)
137 (format t
"~{~& | ~S => ~S~}~%" (funcall extras
)))
141 (defmethod print-failure (type form expected actual extras
)
142 (format t
"~& | Expected ~{~S~^; ~} " expected
)
143 (format t
"~<~% | ~:;but saw ~{~S~^; ~}~>" actual
))
145 (defmethod print-failure ((type (eql :error
))
146 form expected actual extras
)
147 (format t
"~& | ~@[Should have signalled ~{~S~^; ~} but saw~]"
149 (format t
" ~{~S~^; ~}" actual
))
151 (defmethod print-failure ((type (eql :macro
))
152 form expected actual extras
)
153 (format t
"~& | Should have expanded to ~{~S~^; ~} " expected
)
154 (format t
"~<~%~:;but saw ~{~S~^; ~}~>" actual
))
156 (defmethod print-failure ((type (eql :output
))
157 form expected actual extras
)
158 (format t
"~& | Should have printed ~{~S~^; ~} " expected
)
159 (format t
"~<~%~:;but saw ~{~S~^; ~}~>" actual
))
161 (defun print-error (condition)
162 "Print the error condition."
163 (let ((*print-escape
* nil
))
164 (format t
"~& | Execution error:~% | ~W" condition
)
165 (format t
"~& |~%")))
167 (defun print-summary (name pass fail
&optional exerr
)
168 "Print a summary of the test results."
169 (format t
"~&~A: ~S assertions passed, ~S failed"
171 (format t
"~@[, ~S execution errors~].~2%" exerr
))
173 ;;; Global unit test database
175 (defparameter *test-db
* (make-hash-table :test
#'eq
)
176 "The unit test database is simply a hash table.")
178 (defun package-table (package &optional create
)
180 ((gethash (find-package package
) *test-db
*))
182 (setf (gethash package
*test-db
*) (make-hash-table)))
183 (t (warn "No tests defined for package: ~S" package
))))
185 ;;; Global tags database
187 (defparameter *tag-db
* (make-hash-table :test
#'eq
)
188 "The tag database is simply a hash table.")
190 (defun package-tags (package &optional create
)
191 "Return the tags DB for the package."
193 ((gethash (find-package package
) *tag-db
*))
195 (setf (gethash package
*tag-db
*) (make-hash-table)))
196 (t (warn "No tags defined for package: ~S" package
))))
198 (defclass unit-test
()
207 (:default-initargs
:doc
"" :code
())
209 "Organize the unit test documentation and code."))
211 ;;; NOTE: Shamelessly taken from PG's analyze-body
212 (defun parse-body (body &optional doc tag
)
213 "Separate the components of the body."
214 (let ((item (first body
)))
216 ((and (listp item
) (eq :tag
(first item
)))
217 (parse-body (rest body
) doc
(nconc (rest item
) tag
)))
218 ((and (stringp item
) (not doc
) (rest body
))
220 (values doc tag
(rest body
))
221 (parse-body (rest body
) doc tag
)))
222 (t (values doc tag body
)))))
224 (defmacro define-test
(name &body body
)
225 "Store the test in the test database."
226 (multiple-value-bind (doc tag code
) (parse-body body
)
230 (gethash ',name
(package-table *package
* t
))
231 (make-instance 'unit-test
:doc
,doc
:code
',code
))
233 (loop for tag in
',tag do
235 ',name
(gethash tag
(package-tags *package
* t
))))
236 ;; Return the name of the test
241 (defun list-tests (&optional
(package *package
*))
242 "Return a list of the tests in package."
243 (let ((table (package-table package
)))
245 (loop for test-name being each hash-key in table
246 collect test-name
))))
248 (defun test-documentation (name &optional
(package *package
*))
249 "Return the documentation for the test."
250 (let ((unit-test (gethash name
(package-table package
))))
252 (warn "No code defined for test ~A in package ~S."
256 (defun test-code (name &optional
(package *package
*))
257 "Returns the code stored for the test name."
258 (let ((unit-test (gethash name
(package-table package
))))
260 (warn "No code defined for test ~A in package ~S."
264 ;;; 0.8.1 Compatibility revision for Quicklisp
265 (defun remove-all-tests (&optional
(package *package
*))
266 (remove-tests :all package
))
268 (defun remove-tests (names &optional
(package *package
*))
269 "Remove individual tests or entire sets."
274 (remhash (find-package package
) *test-db
*)
275 (remhash (find-package package
) *tag-db
*)))
276 (let ((table (package-table package
)))
279 (loop for name in names
280 always
(remhash name table
)
281 collect name into removed
282 finally
(return removed
))
283 ;; Remove tests from tags
284 (loop with tags
= (package-tags package
)
285 for tag being each hash-key in tags
286 using
(hash-value tagged-tests
)
290 (set-difference tagged-tests names
)))))))
294 (defun %tests-from-all-tags
(&optional
(package *package
*))
295 "Return all of the tests that have been tagged."
296 (loop for tests being each hash-value in
(package-tags package
)
297 nconc
(copy-list tests
) into all-tests
298 finally
(return (delete-duplicates all-tests
))))
300 (defun %tests-from-tags
(tags &optional
(package *package
*))
301 "Return the tests associated with the tags."
302 (loop with table
= (package-tags package
)
304 as tests
= (gethash tag table
)
305 nconc
(copy-list tests
) into all-tests
306 finally
(return (delete-duplicates all-tests
))))
308 (defun list-tags (&optional
(package *package
*))
309 "Return a list of the tags in package."
310 (let ((tags (package-tags package
)))
312 (loop for tag being each hash-key in tags
315 (defun tagged-tests (tags &optional
(package *package
*))
316 "Run the tests associated with the specified tags in package."
318 (%tests-from-all-tags package
)
319 (%tests-from-tags tags package
)))
321 (defun remove-tags (tags &optional
(package *package
*))
322 "Remove individual tags or entire sets."
326 (remhash (find-package package
) *tag-db
*))
327 (let ((table (package-tags package
)))
329 (loop for tag in tags
330 always
(remhash tag table
)
331 collect tag into removed
332 finally
(return removed
))))))
336 (defmacro assert-eq
(expected form
&rest extras
)
337 "Assert whether expected and form are EQ."
338 `(expand-assert :equal
,form
,form
,expected
,extras
:test
#'eq
))
340 (defmacro assert-eql
(expected form
&rest extras
)
341 "Assert whether expected and form are EQL."
342 `(expand-assert :equal
,form
,form
,expected
,extras
:test
#'eql
))
344 (defmacro assert-equal
(expected form
&rest extras
)
345 "Assert whether expected and form are EQUAL."
346 `(expand-assert :equal
,form
,form
,expected
,extras
:test
#'equal
))
348 (defmacro assert-equalp
(expected form
&rest extras
)
349 "Assert whether expected and form are EQUALP."
350 `(expand-assert :equal
,form
,form
,expected
,extras
:test
#'equalp
))
352 (defmacro assert-error
(condition form
&rest extras
)
353 "Assert whether form signals condition."
354 `(expand-assert :error
,form
(expand-error-form ,form
)
357 (defmacro assert-expands
(expansion form
&rest extras
)
358 "Assert whether form expands to expansion."
359 `(expand-assert :macro
,form
360 (expand-macro-form ,form nil
)
363 (defmacro assert-false
(form &rest extras
)
364 "Assert whether the form is false."
365 `(expand-assert :result
,form
,form nil
,extras
))
367 (defmacro assert-equality
(test expected form
&rest extras
)
368 "Assert whether expected and form are equal according to test."
369 `(expand-assert :equal
,form
,form
,expected
,extras
:test
,test
))
371 (defmacro assert-prints
(output form
&rest extras
)
372 "Assert whether printing the form generates the output."
373 `(expand-assert :output
,form
(expand-output-form ,form
)
376 (defmacro assert-true
(form &rest extras
)
377 "Assert whether the form is true."
378 `(expand-assert :result
,form
,form t
,extras
))
380 (defmacro expand-assert
(type form body expected extras
&key
(test '#'eql
))
381 "Expand the assertion to the internal format."
382 `(internal-assert ,type
',form
384 (lambda () ,expected
)
385 (expand-extras ,extras
)
388 (defmacro expand-error-form
(form)
389 "Wrap the error assertion in HANDLER-CASE."
391 (condition (error) error
)))
393 (defmacro expand-output-form
(form)
394 "Capture the output of the form in a string."
395 (let ((out (gensym)))
396 `(let* ((,out
(make-string-output-stream))
398 (make-broadcast-stream *standard-output
* ,out
)))
400 (get-output-stream-string ,out
))))
402 (defmacro expand-macro-form
(form env
)
403 "Expand the macro form once."
404 `(macroexpand-1 ',form
,env
))
406 (defmacro expand-extras
(extras)
407 "Expand extra forms."
409 (list ,@(mapcan (lambda (form) (list `',form form
)) extras
))))
411 (defun internal-assert
412 (type form code-thunk expected-thunk extras test
)
413 "Perform the assertion and record the results."
414 (let ((expected (multiple-value-list (funcall expected-thunk
)))
415 (actual (multiple-value-list (funcall code-thunk
)))
417 ;; Count the assertion
418 (if (setq passed
(test-passed-p type expected actual test
))
421 ;; Report the assertion
422 (when (and (not passed
) *print-failures
*)
423 (print-failure type form expected actual extras
))
427 ;;; Test passed predicate.
429 (defgeneric test-passed-p
(type expected actual test
)
431 "Return the result of the test."))
433 (defmethod test-passed-p ((type (eql :error
)) expected actual test
)
434 "Return the result of the error assertion."
436 (eql (car actual
) (car expected
))
437 (typep (car actual
) (car expected
))))
439 (defmethod test-passed-p ((type (eql :equal
)) expected actual test
)
440 "Return the result of the equality assertion."
442 (<= (length expected
) (length actual
))
443 (every test expected actual
)))
445 (defmethod test-passed-p ((type (eql :macro
)) expected actual test
)
446 "Return the result of the macro expansion."
447 (equal (car actual
) (car expected
)))
449 (defmethod test-passed-p ((type (eql :output
)) expected actual test
)
450 "Return the result of the printed output."
452 (string-trim '(#\newline
#\return
#\space
) (car actual
))
455 (defmethod test-passed-p ((type (eql :result
)) expected actual test
)
456 "Return the result of the assertion."
457 (logically-equal (car actual
) (car expected
)))
461 (defclass test-results
()
465 :accessor test-names
)
481 :accessor failed-tests
)
485 :accessor error-tests
)
489 :accessor missing-tests
))
490 (:default-initargs
:test-names
())
492 "Store the results of the tests for further evaluation."))
494 (defmethod print-object ((object test-results
) stream
)
495 "Print the summary counts with the object."
496 (format stream
"#<~A Total(~D) Passed(~D) Failed(~D) Errors(~D)>~%"
497 (class-name (class-of object
))
498 (+ (pass object
) (fail object
))
499 (pass object
) (fail object
) (exerr object
)))
501 (defun record-result (test-name code results
)
502 "Run the test code and record the result."
503 (multiple-value-bind (pass fail exerr
)
504 (run-test-thunk code
)
505 (push test-name
(test-names results
))
506 ;; Count passed tests
508 (incf (pass results
) pass
))
509 ;; Count failed tests and record name
511 (incf (fail results
) fail
)
512 (push test-name
(failed-tests results
)))
513 ;; Count errors and record name
514 (when (eq :error exerr
)
515 (incf (exerr results
))
516 (push test-name
(error-tests results
)))
517 ;; Print a summary of the results
518 (when (or *print-summary
* *print-failures
* *print-errors
*)
521 (when (eq :error exerr
) 1)))))
523 (defun summarize-results (results)
524 "Print a summary of all results."
525 (let ((pass (pass results
))
526 (fail (fail results
)))
527 (format t
"~&Unit Test Summary~%")
528 (format t
" | ~D assertions total~%" (+ pass fail
))
529 (format t
" | ~D passed~%" pass
)
530 (format t
" | ~D failed~%" fail
)
531 (format t
" | ~D execution errors~%" (exerr results
))
532 (format t
" | ~D missing tests~2%"
533 (length (missing-tests results
)))))
537 (defun run-code (code)
538 "Run the code to test the assertions."
539 (funcall (coerce `(lambda () ,@code
) 'function
)))
541 (defun run-test-thunk (code)
544 (handler-case (run-code code
)
547 (print-error condition
))
548 (if (use-debugger-p condition
)
550 (return-from run-test-thunk
551 (values *pass
* *fail
* :error
)))))
552 ;; Return the result count
553 (values *pass
* *fail
* nil
)))
555 (defun %run-all-thunks
(&optional
(package *package
*))
556 "Run all of the test thunks in the package."
558 with results
= (make-instance 'test-results
)
559 for test-name being each hash-key in
(package-table package
)
560 using
(hash-value unit-test
)
562 (record-result test-name
(code unit-test
) results
)
564 (push test-name
(missing-tests results
))
565 ;; Summarize and return the test results
567 (summarize-results results
)
570 (defun %run-thunks
(test-names &optional
(package *package
*))
571 "Run the list of test thunks in the package."
573 with table
= (package-table package
)
574 and results
= (make-instance 'test-results
)
575 for test-name in test-names
576 as unit-test
= (gethash test-name table
)
578 (record-result test-name
(code unit-test
) results
)
580 (push test-name
(missing-tests results
))
582 (summarize-results results
)
585 (defun new-run-tests (test-names &optional
(package *package
*))
586 "Run the specified tests in package."
587 (if (eq :all test-names
)
588 (%run-all-thunks package
)
589 (%run-thunks test-names package
)))
591 (defun run-tags (tags &optional
(package *package
*))
592 "Run the tests associated with the specified tags in package."
593 (%run-thunks
(get-tagged-tests tags package
) package
))
595 ;;; Useful equality predicates for tests
597 ;;; (LOGICALLY-EQUAL x y) => true or false
598 ;;; Return true if x and y both false or both true
599 (defun logically-equal (x y
)
600 (eql (not x
) (not y
)))
602 ;;; (SET-EQUAL l1 l2 :test) => true or false
603 ;;; Return true if every element of l1 is an element of l2
605 (defun set-equal (l1 l2
&key
(test #'equal
))
608 (subsetp l1 l2
:test test
)
609 (subsetp l2 l1
:test test
)))
611 (pushnew :lisp-unit common-lisp
:*features
*)