[funds-cvs] r83 - trunk/funds/tests

abaine at common-lisp.net abaine at common-lisp.net
Wed Jul 11 15:18:56 UTC 2007


Author: abaine
Date: Wed Jul 11 11:18:55 2007
New Revision: 83

Added:
   trunk/funds/tests/lisp-unit.lisp
Log:
Included lisp-unit.lisp in the project.

Added: trunk/funds/tests/lisp-unit.lisp
==============================================================================
--- (empty file)
+++ trunk/funds/tests/lisp-unit.lisp	Wed Jul 11 11:18:55 2007
@@ -0,0 +1,429 @@
+;;;-*- Mode: Lisp; Package: LISP-UNIT -*-
+
+#|
+Copyright (c) 2004-2005 Christopher K. Riesbeck
+
+Permission is hereby granted, free of charge, to any person obtaining 
+a copy of this software and associated documentation files (the "Software"), 
+to deal in the Software without restriction, including without limitation 
+the rights to use, copy, modify, merge, publish, distribute, sublicense, 
+and/or sell copies of the Software, and to permit persons to whom the 
+Software is furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included 
+in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS 
+OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 
+THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR 
+OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 
+ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 
+OTHER DEALINGS IN THE SOFTWARE.
+|#
+
+
+;;; A test suite package, modelled after JUnit.
+;;; Author: Chris Riesbeck
+;;; 
+;;; Update history:
+;;;
+;;; 04/07/06 added ~<...~> to remaining error output forms [CKR]
+;;; 04/06/06 added ~<...~> to compact error output better [CKR]
+;;; 04/06/06 fixed RUN-TESTS to get tests dynamically (bug reported
+;;;          by Daniel Edward Burke) [CKR]
+;;; 02/08/06 added newlines to error output [CKR]
+;;; 12/30/05 renamed ASSERT-PREDICATE to ASSERT-EQUALITY [CKR]
+;;; 12/29/05 added ASSERT-EQ, ASSERT-EQL, ASSERT-EQUALP [CKR]
+;;; 12/22/05 recoded use-debugger to use handler-bind, added option to prompt for debugger, 
+;;; 11/07/05 added *use-debugger* and assert-predicate [DFB]
+;;; 09/18/05 replaced Academic Free License with MIT Licence [CKR]
+;;; 08/30/05 added license notice [CKR]
+;;; 06/28/05 changed RUN-TESTS to compile code at run time, not expand time [CKR]
+;;; 02/21/05 removed length check from SET-EQUAL [CKR]
+;;; 02/17/05 added RUN-ALL-TESTS [CKR]
+;;; 01/18/05 added ASSERT-EQUAL back in [CKR]
+;;; 01/17/05 much clean up, added WITH-TEST-LISTENER [CKR] 
+;;; 01/15/05 replaced ASSERT-EQUAL etc. with ASSERT-TRUE and ASSERT-FALSE [CKR]
+;;; 01/04/05 changed COLLECT-RESULTS to echo output on *STANDARD-OUTPuT* [CKR]
+;;; 01/04/05 added optional package argument to REMOVE-ALL-TESTS [CKR]
+;;; 01/04/05 changed OUTPUT-OK-P to trim spaces and returns [CKR]
+;;; 01/04/05 changed OUTPUT-OK-P to not check output except when asked to [CKR]
+;;; 12/03/04 merged REMOVE-TEST into REMOVE-TESTS [CKR]
+;;; 12/03/04 removed ability to pass forms to RUN-TESTS [CKR]
+;;; 12/03/04 refactored RUN-TESTS expansion into RUN-TEST-THUNKS [CKR]
+;;; 12/02/04 changed to group tests under packages [CKR]
+;;; 11/30/04 changed assertions to put expected value first, like JUnit [CKR]
+;;; 11/30/04 improved error handling and summarization [CKR]
+;;; 11/30/04 generalized RUN-TESTS, removed RUN-TEST [CKR]
+;;; 02/27/04 fixed ASSERT-PRINTS not ignoring value [CKR]
+;;; 02/07/04 fixed ASSERT-EXPANDS failure message [CKR]
+;;; 02/07/04 added ASSERT-NULL, ASSERT-NOT-NULL [CKR]
+;;; 01/31/04 added error handling and totalling to RUN-TESTS [CKR]
+;;; 01/31/04 made RUN-TEST/RUN-TESTS macros [CKR]
+;;; 01/29/04 fixed ASSERT-EXPANDS quote bug [CKR]
+;;; 01/28/04 major changes from BUG-FINDER to be more like JUnit [CKR]
+
+
+#|
+How to use
+----------
+
+1. Read the documentation in lisp-unit.html.
+
+2. Make a file of DEFINE-TEST's. See exercise-tests.lisp for many
+examples. If you want, start your test file with (REMOVE-TESTS) to
+clear any previously defined tests.
+
+2. Load this file.
+
+2. (use-package :lisp-unit)
+
+3. Load your code file and your file of tests.
+
+4. Test your code with (RUN-TESTS test-name1 test-name2 ...) -- no quotes! --
+or simply (RUN-TESTS) to run all defined tests.
+
+A summary of how many tests passed and failed will be printed,
+with details on the failures.
+
+Note: Nothing is compiled until RUN-TESTS is expanded. Redefining
+functions or even macros does not require reloading any tests.
+
+For more information, see lisp-unit.html. 
+
+|#
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Packages
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(cl:defpackage #:lisp-unit
+  (:use #:common-lisp)
+  (:export #:define-test #:run-all-tests #:run-tests
+           #:assert-eq #:assert-eql #:assert-equal #:assert-equalp
+           #:assert-error #:assert-expands #:assert-false 
+           #:assert-equality #:assert-prints #:assert-true
+           #:get-test-code #:get-tests
+           #:remove-all-tests #:remove-tests
+           #:logically-equal #:set-equal
+           #:use-debugger
+           #:with-test-listener)
+  )
+
+(in-package #:lisp-unit)
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Globals
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defparameter *test-listener* nil)
+
+(defparameter *tests* (make-hash-table))
+
+;;; Used by RUN-TESTS to collect summary statistics
+(defvar *test-count* 0)
+(defvar *pass-count* 0)
+
+;;; Set by RUN-TESTS for use by SHOW-FAILURE
+(defvar *test-name* nil)
+
+;;; If nil, errors in tests are caught and counted.
+;;; If :ask, user is given option of entering debugger or not.
+;;; If true and not :ask, debugger is entered.
+(defparameter *use-debugger* nil)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Macros
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; DEFINE-TEST
+
+(defmacro define-test (name &body body)
+  `(progn
+     (store-test-code ',name ',body)
+     ',name))
+
+;;; ASSERT macros
+
+(defmacro assert-eq (expected form &rest extras)
+ (expand-assert :equal form form expected extras :test #'eq))
+
+(defmacro assert-eql (expected form &rest extras)
+ (expand-assert :equal form form expected extras :test #'eql))
+
+(defmacro assert-equal (expected form &rest extras)
+ (expand-assert :equal form form expected extras :test #'equal))
+
+(defmacro assert-equalp (expected form &rest extras)
+ (expand-assert :equal form form expected extras :test #'equalp))
+
+(defmacro assert-error (condition form &rest extras)
+ (expand-assert :error form (expand-error-form form)
+                condition extras))
+
+(defmacro assert-expands (&environment env expansion form &rest extras)
+  (expand-assert :macro form 
+                 (expand-macro-form form #+lispworks nil #-lispworks env)
+                 expansion extras))
+
+(defmacro assert-false (form &rest extras)
+  (expand-assert :result form form nil extras))
+ 
+(defmacro assert-equality (test expected form &rest extras)
+ (expand-assert :equal form form expected extras :test test))
+
+(defmacro assert-prints (output form &rest extras)
+  (expand-assert :output form (expand-output-form form)
+                 output extras))
+
+(defmacro assert-true (form &rest extras)
+  (expand-assert :result form form t extras))
+
+
+(defun expand-assert (type form body expected extras &key (test #'eql))
+  `(internal-assert
+    ,type ',form #'(lambda () ,body) #'(lambda () ,expected) ,(expand-extras extras), test))
+  
+(defun expand-error-form (form)
+  `(handler-case ,form
+     (condition (error) error)))
+
+(defun expand-output-form (form)
+  (let ((out (gensym)))
+    `(let* ((,out (make-string-output-stream))
+            (*standard-output* (make-broadcast-stream *standard-output* ,out)))
+       ,form
+       (get-output-stream-string ,out))))
+
+(defun expand-macro-form (form env)
+  `(macroexpand-1 ',form ,env))
+
+(defun expand-extras (extras)
+  `#'(lambda ()
+       (list ,@(mapcan #'(lambda (form) (list `',form form)) extras))))
+    
+
+;;; RUN-TESTS
+
+(defmacro run-all-tests (package &rest tests)
+  `(let ((*package* (find-package ',package)))
+     (run-tests
+      ,@(mapcar #'(lambda (test) (find-symbol (symbol-name test) package))
+          tests))))
+
+(defmacro run-tests (&rest names)
+  `(run-test-thunks (get-test-thunks ,(if (null names) '(get-tests *package*) `',names))))
+
+(defun get-test-thunks (names &optional (package *package*))
+  (mapcar #'(lambda (name) (get-test-thunk name package))
+    names))
+
+(defun get-test-thunk (name package)
+  (assert (get-test-code name package) (name package)
+          "No test defined for ~S in package ~S" name package)
+  (list name (coerce `(lambda () ,@(get-test-code name)) 'function)))
+
+(defun use-debugger (&optional (flag t))
+  (setq *use-debugger* flag))
+
+;;; WITH-TEST-LISTENER
+(defmacro with-test-listener (listener &body body)
+  `(let ((*test-listener* #',listener)) , at body))
+  
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Public functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun get-test-code (name &optional (package *package*))
+  (let ((table (get-package-table package)))
+    (unless (null table)
+      (gethash name table))))
+
+(defun get-tests (&optional (package *package*))
+  (let ((l nil)
+        (table (get-package-table package)))
+    (cond ((null table) nil)
+          (t
+           (maphash #'(lambda (key val)
+                        (declare (ignore val))
+                        (push key l))
+                    table)
+           (sort l #'string< :key #'string)))))
+
+
+(defun remove-tests (names &optional (package *package*))
+  (let ((table (get-package-table package)))
+    (unless (null table)
+      (if (null names)
+          (clrhash table)
+        (dolist (name names)
+          (remhash name table))))))
+
+(defun remove-all-tests (&optional (package *package*))
+  (if (null package)
+      (clrhash *tests*)
+    (remhash (find-package package) *tests*)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Private functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+;;; DEFINE-TEST support
+
+(defun get-package-table (package &key create)
+  (let ((table (gethash (find-package package) *tests*)))
+    (or table
+        (and create
+             (setf (gethash package *tests*)
+                   (make-hash-table))))))
+
+(defun get-test-name (form)
+  (if (atom form) form (cadr form)))
+
+(defun store-test-code (name code &optional (package *package*))
+  (setf (gethash name
+                 (get-package-table package :create t))
+        code))
+
+
+;;; ASSERTION support
+
+(defun internal-assert (type form code-thunk expected-thunk extras test)
+  (let* ((expected (multiple-value-list (funcall expected-thunk)))
+         (actual (multiple-value-list (funcall code-thunk)))
+         (passed (test-passed-p type expected actual test)))
+    
+    (incf *test-count*)
+    (when passed
+      (incf *pass-count*))
+    
+    (record-result passed type form expected actual extras)
+    
+    passed))
+
+(defun record-result (passed type form expected actual extras)
+  (funcall (or *test-listener* 'default-listener)
+           passed type *test-name* form expected actual 
+           (and extras (funcall extras))
+           *test-count* *pass-count*))
+
+(defun default-listener
+    (passed type name form expected actual extras test-count pass-count)
+  (declare (ignore test-count pass-count))
+  (unless passed
+    (show-failure type (get-failure-message type)
+                  name form expected actual extras)))
+
+(defun test-passed-p (type expected actual test)
+  (ecase type
+    (:error
+     (or (eql (car actual) (car expected))
+         (typep (car actual) (car expected))))
+    (:equal
+     (and (<= (length expected) (length actual))
+          (every test expected actual)))
+    (:macro
+     (equal (car actual) (car expected)))
+    (:output
+     (string= (string-trim '(#\newline #\return #\space) 
+                           (car actual))
+              (car expected)))
+    (:result
+     (logically-equal (car actual) (car expected)))
+    ))
+
+
+;;; RUN-TESTS support
+
+(defun run-test-thunks (test-thunks)
+  (unless (null test-thunks)
+    (let ((total-test-count 0)
+          (total-pass-count 0)
+          (total-error-count 0))
+      (dolist (test-thunk test-thunks)
+        (multiple-value-bind (test-count pass-count error-count)
+            (run-test-thunk (car test-thunk) (cadr test-thunk))
+          (incf total-test-count test-count)
+          (incf total-pass-count pass-count)
+          (incf total-error-count error-count)))
+      (unless (null (cdr test-thunks))
+        (show-summary 'total total-test-count total-pass-count total-error-count))
+      (values))))
+
+(defun run-test-thunk (*test-name* thunk)
+  (if (null thunk)
+      (format t "~&    Test ~S not found" *test-name*)
+    (prog ((*test-count* 0)
+           (*pass-count* 0)
+           (error-count 0))
+      (handler-bind 
+          ((error #'(lambda (e)
+                      (let ((*print-escape* nil))
+                        (setq error-count 1)         
+                        (format t "~&    ~S: ~W" *test-name* e))
+                      (if (use-debugger-p e) e (go exit)))))
+        (funcall thunk)
+        (show-summary *test-name* *test-count* *pass-count*))
+      exit
+      (return (values *test-count* *pass-count* error-count)))))
+
+(defun use-debugger-p (e)
+  (and *use-debugger*
+       (or (not (eql *use-debugger* :ask))
+           (y-or-n-p "~A -- debug?" e))))
+
+;;; OUTPUT support
+
+(defun get-failure-message (type)
+  (case type
+    (:error "~&~@[Should have signalled ~{~S~^; ~} but saw~] ~{~S~^; ~}")
+    (:macro "~&Should have expanded to ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
+    (:output "~&Should have printed ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
+    (t "~&Expected ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>")
+    ))
+
+(defun show-failure (type msg name form expected actual extras)
+  (format t "~&~@[~S: ~]~S failed: " name form)
+  (format t msg expected actual)
+  (format t "~{~&   ~S => ~S~}~%" extras)
+  type)
+
+(defun show-summary (name test-count pass-count &optional error-count)
+  (format t "~&~A: ~S assertions passed, ~S failed~@[, ~S execution errors~]."
+          name pass-count (- test-count pass-count) error-count))
+
+(defun collect-form-values (form values)
+  (mapcan #'(lambda (form-arg value)
+              (if (constantp form-arg)
+                  nil
+                (list form-arg value)))
+          (cdr form)
+          values))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Useful equality predicates for tests
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; (LOGICALLY-EQUAL x y) => true or false
+;;;   Return true if x and y both false or both true
+
+(defun logically-equal (x y)
+  (eql (not x) (not y)))
+
+;;; (SET-EQUAL l1 l2 :test) => true or false
+;;;   Return true if every element of l1 is an element of l2
+;;;   and vice versa.
+
+(defun set-equal (l1 l2 &key (test #'equal))
+  (and (listp l1)
+       (listp l2)
+       (subsetp l1 l2 :test test)
+       (subsetp l2 l1 :test test)))
+
+
+(provide "lisp-unit")



More information about the Funds-cvs mailing list