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
93 ;; Functions for extensibility via signals
94 (:export
:test-run-complete
97 (:export
:logically-equal
:set-equal
))
99 (in-package :lisp-unit
)
103 (defparameter *pass
* ()
104 "The passed assertion results.")
106 (defparameter *fail
* ()
107 "The failed assertion results.")
109 (defun reset-counters ()
110 "Reset the counters to empty lists."
111 (setf *pass
* () *fail
* ()))
115 (defparameter *print-summary
* nil
116 "Print a summary of the pass, fail, and error count if non-nil.")
118 (defparameter *print-failures
* nil
119 "Print failure messages if non-NIL.")
121 (defparameter *print-errors
* nil
122 "Print error messages if non-NIL.")
124 (defparameter *use-debugger
* nil
125 "If not NIL, enter the debugger when an error is encountered in an
128 (defun use-debugger-p (condition)
129 "Debug or ignore errors."
131 ((eq :ask
*use-debugger
*)
132 (y-or-n-p "~A -- debug?" condition
))
135 (defun use-debugger (&optional
(flag t
))
136 "Use the debugger when testing, or not."
137 (setq *use-debugger
* flag
))
139 ;;; Global unit test database
141 (defparameter *test-db
* (make-hash-table :test
#'eq
)
142 "The unit test database is simply a hash table.")
144 (defun package-table (package &optional create
)
146 ((gethash (find-package package
) *test-db
*))
148 (setf (gethash package
*test-db
*) (make-hash-table)))
149 (t (warn "No tests defined for package: ~S" package
))))
151 ;;; Global tags database
153 (defparameter *tag-db
* (make-hash-table :test
#'eq
)
154 "The tag database is simply a hash table.")
156 (defun package-tags (package &optional create
)
157 "Return the tags DB for the package."
159 ((gethash (find-package package
) *tag-db
*))
161 (setf (gethash package
*tag-db
*) (make-hash-table)))
162 (t (warn "No tags defined for package: ~S" package
))))
164 ;;; Unit test definition
166 (defclass unit-test
()
175 (:default-initargs
:doc
"" :code
())
177 "Organize the unit test documentation and code."))
179 ;;; NOTE: Shamelessly taken from PG's analyze-body
180 (defun parse-body (body &optional doc tag
)
181 "Separate the components of the body."
182 (let ((item (first body
)))
184 ((and (listp item
) (eq :tag
(first item
)))
185 (parse-body (rest body
) doc
(nconc (rest item
) tag
)))
186 ((and (stringp item
) (not doc
) (rest body
))
188 (values doc tag
(rest body
))
189 (parse-body (rest body
) doc tag
)))
190 (t (values doc tag body
)))))
192 (defmacro define-test
(name &body body
)
193 "Store the test in the test database."
194 (let ((qname (gensym "NAME-")))
195 (multiple-value-bind (doc tag code
) (parse-body body
)
196 `(let* ((,qname
',name
)
197 (doc (or ,doc
(string ,qname
))))
200 (gethash ,qname
(package-table *package
* t
))
201 (make-instance 'unit-test
:doc doc
:code
',code
))
203 (loop for tag in
',tag do
205 ,qname
(gethash tag
(package-tags *package
* t
))))
206 ;; Return the name of the test
211 (defun list-tests (&optional
(package *package
*))
212 "Return a list of the tests in package."
213 (let ((table (package-table package
)))
215 (loop for test-name being each hash-key in table
216 collect test-name
))))
218 (defun test-documentation (name &optional
(package *package
*))
219 "Return the documentation for the test."
220 (let ((unit-test (gethash name
(package-table package
))))
222 (warn "No code defined for test ~A in package ~S."
226 (defun test-code (name &optional
(package *package
*))
227 "Returns the code stored for the test name."
228 (let ((unit-test (gethash name
(package-table package
))))
230 (warn "No code defined for test ~A in package ~S."
234 (defun remove-tests (names &optional
(package *package
*))
235 "Remove individual tests or entire sets."
240 (remhash (find-package package
) *test-db
*)
241 (remhash (find-package package
) *tag-db
*)))
242 (let ((table (package-table package
)))
245 (loop for name in names
246 always
(remhash name table
)
247 collect name into removed
248 finally
(return removed
))
249 ;; Remove tests from tags
250 (loop with tags
= (package-tags package
)
251 for tag being each hash-key in tags
252 using
(hash-value tagged-tests
)
256 (set-difference tagged-tests names
)))))))
260 (defun %tests-from-all-tags
(&optional
(package *package
*))
261 "Return all of the tests that have been tagged."
262 (loop for tests being each hash-value in
(package-tags package
)
263 nconc
(copy-list tests
) into all-tests
264 finally
(return (delete-duplicates all-tests
))))
266 (defun %tests-from-tags
(tags &optional
(package *package
*))
267 "Return the tests associated with the tags."
268 (loop with table
= (package-tags package
)
270 as tests
= (gethash tag table
)
271 if
(null tests
) do
(warn "No tests tagged with ~S." tag
)
272 else nconc
(copy-list tests
) into all-tests
273 finally
(return (delete-duplicates all-tests
))))
275 (defun list-tags (&optional
(package *package
*))
276 "Return a list of the tags in package."
277 (let ((tags (package-tags package
)))
279 (loop for tag being each hash-key in tags collect tag
))))
281 (defun tagged-tests (tags &optional
(package *package
*))
282 "Return a list of the tests associated with the tags."
284 (%tests-from-all-tags package
)
285 (%tests-from-tags tags package
)))
287 (defun remove-tags (tags &optional
(package *package
*))
288 "Remove individual tags or entire sets."
292 (remhash (find-package package
) *tag-db
*))
293 (let ((table (package-tags package
)))
295 (loop for tag in tags
296 always
(remhash tag table
)
297 collect tag into removed
298 finally
(return removed
))))))
302 (defmacro assert-eq
(expected form
&rest extras
)
303 "Assert whether expected and form are EQ."
304 `(expand-assert :equal
,form
,form
,expected
,extras
:test
#'eq
))
306 (defmacro assert-eql
(expected form
&rest extras
)
307 "Assert whether expected and form are EQL."
308 `(expand-assert :equal
,form
,form
,expected
,extras
:test
#'eql
))
310 (defmacro assert-equal
(expected form
&rest extras
)
311 "Assert whether expected and form are EQUAL."
312 `(expand-assert :equal
,form
,form
,expected
,extras
:test
#'equal
))
314 (defmacro assert-equalp
(expected form
&rest extras
)
315 "Assert whether expected and form are EQUALP."
316 `(expand-assert :equal
,form
,form
,expected
,extras
:test
#'equalp
))
318 (defmacro assert-error
(condition form
&rest extras
)
319 "Assert whether form signals condition."
320 `(expand-assert :error
,form
(expand-error-form ,form
)
323 (defmacro assert-expands
(expansion form
&rest extras
)
324 "Assert whether form expands to expansion."
325 `(expand-assert :macro
,form
326 (expand-macro-form ,form nil
)
329 (defmacro assert-false
(form &rest extras
)
330 "Assert whether the form is false."
331 `(expand-assert :result
,form
,form nil
,extras
))
333 (defmacro assert-equality
(test expected form
&rest extras
)
334 "Assert whether expected and form are equal according to test."
335 `(expand-assert :equal
,form
,form
,expected
,extras
:test
,test
))
337 (defmacro assert-prints
(output form
&rest extras
)
338 "Assert whether printing the form generates the output."
339 `(expand-assert :output
,form
(expand-output-form ,form
)
342 (defmacro assert-true
(form &rest extras
)
343 "Assert whether the form is true."
344 `(expand-assert :result
,form
,form t
,extras
))
346 (defmacro expand-assert
(type form body expected extras
&key
(test '#'eql
))
347 "Expand the assertion to the internal format."
348 `(internal-assert ,type
',form
350 (lambda () ,expected
)
351 (expand-extras ,extras
)
354 (defmacro expand-error-form
(form)
355 "Wrap the error assertion in HANDLER-CASE."
357 (condition (error) error
)))
359 (defmacro expand-output-form
(form)
360 "Capture the output of the form in a string."
361 (let ((out (gensym)))
362 `(let* ((,out
(make-string-output-stream))
364 (make-broadcast-stream *standard-output
* ,out
)))
366 (get-output-stream-string ,out
))))
368 (defmacro expand-macro-form
(form env
)
369 "Expand the macro form once."
370 `(macroexpand-1 ',form
,env
))
372 (defmacro expand-extras
(extras)
373 "Expand extra forms."
375 (list ,@(mapcan (lambda (form) (list `',form form
)) extras
))))
377 (defclass assert-result
()
401 "Result of the assertion."))
403 (defclass equal-result
(assert-result)
406 "Result of an equal assertion type."))
408 (defmethod initialize-instance :after
((self equal-result
)
410 "Return the result of the equality assertion."
411 (with-slots (actual expected test passed
) self
414 (<= (length expected
) (length actual
))
415 (every test expected actual
)))))
417 (defclass error-result
(assert-result)
420 "Result of an error assertion type."))
422 (defmethod initialize-instance :after
((self error-result
)
424 "Evaluate the result."
425 (with-slots (actual expected passed
) self
429 (eql (car actual
) (car expected
))
430 (typep (car actual
) (car expected
))))))
432 (defclass macro-result
(assert-result)
435 "Result of a macro assertion type."))
437 (defmethod initialize-instance :after
((self macro-result
)
439 "Return the result of the macro expansion."
440 (with-slots (actual expected passed
) self
441 (setf passed
(equal (car actual
) (car expected
)))))
443 (defclass boolean-result
(assert-result)
446 "Result of a result assertion type."))
448 (defmethod initialize-instance :after
((self boolean-result
)
450 "Return the result of the assertion."
451 (with-slots (actual expected passed
) self
452 (setf passed
(logically-equal (car actual
) (car expected
)))))
454 (defclass output-result
(assert-result)
457 "Result of an output assertion type."))
459 (defmethod initialize-instance :after
((self output-result
)
461 "Return the result of the printed output."
462 (with-slots (actual expected passed
) self
466 (string-trim '(#\newline
#\return
#\space
) (car actual
))
469 (defun assert-class (type)
470 "Return the class name for the assertion type."
472 (:equal
'equal-result
)
473 (:error
'error-result
)
474 (:macro
'macro-result
)
475 (:result
'boolean-result
)
476 (:output
'output-result
)))
478 (defun internal-assert
479 (type form code-thunk expected-thunk extras test
)
480 "Perform the assertion and record the results."
485 :actual
(multiple-value-list (funcall code-thunk
))
486 :expected
(multiple-value-list (funcall expected-thunk
))
487 :extras
(when extras
(funcall extras
))
491 (push result
*fail
*))
495 ;;; Unit test results
497 (defclass test-result
()
513 (:default-initargs
:exerr nil
)
515 "Store the results of the unit test."))
517 (defun print-summary (test-result)
518 "Print a summary of the test result."
519 (format t
"~&~A: ~S assertions passed, ~S failed"
521 (length (pass test-result
))
522 (length (fail test-result
)))
523 (if (exerr test-result
)
524 (format t
", and an execution error.")
529 (defun run-code (code)
530 "Run the code to test the assertions."
531 (funcall (coerce `(lambda () ,@code
) 'function
)))
533 (defun run-test-thunk (name code
)
539 (if (use-debugger-p condition
)
541 (return-from run-test-thunk
547 :exerr condition
))))))
549 ;; Return the result count
550 (make-instance 'test-result
555 ;;; Test results database
557 (defclass test-results-db
()
560 :initform
(make-hash-table :test
#'eq
)
577 :accessor failed-tests
)
581 :accessor error-tests
)
585 :accessor missing-tests
))
587 "Store the results of the tests for further evaluation."))
589 (defmethod print-object ((object test-results-db
) stream
)
590 "Print the summary counts with the object."
591 (let ((pass (pass object
))
593 (exerr (exerr object
)))
595 stream
"#<~A Total(~D) Passed(~D) Failed(~D) Errors(~D)>~%"
596 (class-name (class-of object
))
597 (+ pass fail
) pass fail exerr
)))
599 (defun test-names (test-results-db)
600 "Return a list of the test names in the database."
601 (loop for name being each hash-key in
(database test-results-db
)
604 (defun record-result (test-name code results
)
605 "Run the test code and record the result."
606 (let ((result (run-test-thunk test-name code
)))
608 (setf (gethash test-name
(database results
)) result
)
609 ;; Count passed tests
611 (incf (pass results
) (length (pass result
))))
612 ;; Count failed tests and record the name
614 (incf (fail results
) (length (fail result
)))
615 (push test-name
(failed-tests results
)))
616 ;; Count errors and record the name
618 (incf (exerr results
))
619 (push test-name
(error-tests results
)))
621 (when *print-failures
* (print-failures result
))
622 (when *print-errors
* (print-errors result
))
623 (when (or *print-summary
* *print-failures
* *print-errors
*)
624 (print-summary result
))))
626 (defun summarize-results (results)
627 "Print a summary of all results."
628 (let ((pass (pass results
))
629 (fail (fail results
)))
630 (format t
"~&Unit Test Summary~%")
631 (format t
" | ~D assertions total~%" (+ pass fail
))
632 (format t
" | ~D passed~%" pass
)
633 (format t
" | ~D failed~%" fail
)
634 (format t
" | ~D execution errors~%" (exerr results
))
635 (format t
" | ~D missing tests~2%"
636 (length (missing-tests results
)))))
639 (define-condition test-run-complete
()
640 ((results :initarg
:results
:reader results
))
641 (:documentation
"signaled when a test run is finished"))
643 (defun %run-all-thunks
(&optional
(package *package
*))
644 "Run all of the test thunks in the package."
646 with results
= (make-instance 'test-results-db
)
647 for test-name being each hash-key in
(package-table package
)
648 using
(hash-value unit-test
)
650 (record-result test-name
(code unit-test
) results
)
652 (push test-name
(missing-tests results
))
653 ;; Summarize and return the test results
655 (summarize-results results
)
656 (signal 'test-run-complete
:results results
)
659 (defun %run-thunks
(test-names &optional
(package *package
*))
660 "Run the list of test thunks in the package."
662 with table
= (package-table package
)
663 and results
= (make-instance 'test-results-db
)
664 for test-name in test-names
665 as unit-test
= (gethash test-name table
)
667 (record-result test-name
(code unit-test
) results
)
669 (push test-name
(missing-tests results
))
671 (summarize-results results
)
672 (signal 'test-run-complete
:results results
)
675 (defun run-tests (test-names &optional
(package *package
*))
676 "Run the specified tests in package."
678 (if (eq :all test-names
)
679 (%run-all-thunks package
)
680 (%run-thunks test-names package
)))
682 (defun run-tags (tags &optional
(package *package
*))
683 "Run the tests associated with the specified tags in package."
685 (%run-thunks
(tagged-tests tags package
) package
))
689 (defgeneric print-failures
(result)
691 "Report the results of the failed assertion."))
693 (defmethod print-failures :around
((result assert-result
))
694 "Failure header and footer output."
695 (format t
"~& | Failed Form: ~S" (form result
))
697 (when (extras result
)
698 (format t
"~{~& | ~S => ~S~}~%" (extras result
)))
700 (class-name (class-of result
)))
702 (defmethod print-failures ((result assert-result
))
703 (format t
"~& | Expected ~{~S~^; ~} " (expected result
))
704 (format t
"~<~% | ~:;but saw ~{~S~^; ~}~>" (actual result
)))
706 (defmethod print-failures ((result error-result
))
707 (format t
"~& | ~@[Should have signalled ~{~S~^; ~} but saw~]"
709 (format t
" ~{~S~^; ~}" (actual result
)))
711 (defmethod print-failures ((result macro-result
))
712 (format t
"~& | Should have expanded to ~{~S~^; ~} "
714 (format t
"~<~%~:;but saw ~{~S~^; ~}~>" (actual result
)))
716 (defmethod print-failures ((result output-result
))
717 (format t
"~& | Should have printed ~{~S~^; ~} "
719 (format t
"~<~%~:;but saw ~{~S~^; ~}~>"
722 (defmethod print-failures ((result test-result
))
723 "Print the failed assertions in the unit test."
724 (loop for fail in
(fail result
) do
725 (print-failures fail
)))
727 (defmethod print-failures ((results test-results-db
))
728 "Print all of the failure tests."
729 (loop with db
= (database results
)
730 for test in
(failed-tests results
)
731 as result
= (gethash test db
)
733 (print-failures result
)
734 (print-summary result
)))
738 (defgeneric print-errors
(result)
740 "Print the error condition."))
742 (defmethod print-errors ((result test-result
))
743 "Print the error condition."
744 (let ((exerr (exerr result
))
745 (*print-escape
* nil
))
747 (format t
"~& | Execution error:~% | ~W" exerr
)
748 (format t
"~& |~%"))))
750 (defmethod print-errors ((results test-results-db
))
751 "Print all of the error tests."
752 (loop with db
= (database results
)
753 for test in
(error-tests results
)
754 as result
= (gethash test db
)
756 (print-errors result
)
757 (print-summary result
)))
759 ;;; Useful equality predicates for tests
761 (defun logically-equal (x y
)
762 "Return true if x and y are both false or both true."
763 (eql (not x
) (not y
)))
765 (defun set-equal (list1 list2
&rest initargs
&key key
(test #'equal
))
766 "Return true if every element of list1 is an element of list2 and
768 (declare (ignore key test
))
772 (apply #'subsetp list1 list2 initargs
)
773 (apply #'subsetp list2 list1 initargs
)))
775 (pushnew :lisp-unit common-lisp
:*features
*)