--- /dev/null
+xptest - An "Extreme Programming" test framework for Comon Lisp
+======================================================================
+
+xptest is a framework for building test cases, managing test data, and
+putting these together into test suites. It provides a minimal level
+of support for reports on test runs. It's also a nice development
+tool in that one can easily use it for organizing code fragments when
+developing more complex features.
+
+
+License (well, non-License)
+======================================================================
+xptest is in the public domain. It's so simple that even a copyright
+is just a pathetic clinging some romantic notion of the author.
+
+
+Installation
+======================================================================
+
+xptest uses defsystem, so your lisp needs to support defsystem. You
+may need to modify the XPTest.system file in order to tell defsystem
+where the source files are stored, and/or set up the appropirate
+logial path translations. Alternatively you can just load up the
+files by hand.
+
+
+
+Author
+======================================================================
+
+xptest is maintained by Craig Brozefsky <craig@red-bean.com>. Any bug
+reports, comments, or patches can be sent to him.
+
+Others who have contributed:
+Lyn Headley <lyn@onshore.com>
+Stig Erik Sandoe <stig@ii.uib.no>
\ No newline at end of file
--- /dev/null
+;;; -*- Mode: Lisp -*-
+;;;; xptest-eaxmple.lisp --- Example of test suite based on Extreme
+;;;; Programming Framework by Kent Beck
+;;;;
+;;;; Author: Craig Brozefsky <craig@onshore.com>
+;;;; Put in public domain by onShore, Inc
+(in-package :xp-test-example)
+
+;;; First we define some basic fixtures that we are going to need to
+;;; perform our tests. A fixture is a place to hold data we need
+;;; during testing. Often there are many test cases that use the same
+;;; data. Each of these test cases is an instance of a test-fixture.
+
+(def-test-fixture math-fixture ()
+ ((numbera
+ :accessor numbera)
+ (numberb
+ :accessor numberb))
+ (:documentation "Test fixture for math testing"))
+
+;;; Then we define a setup method for the fixture. This method is run
+;;; prior to perfoming any test with an instance of this fixture. It
+;;; should perform all initialization needed, and assume that it is starting
+;;; with a pristine environment, well to a point, use your head here.
+
+(defmethod setup ((fix math-fixture))
+ (setf (numbera fix) 2)
+ (setf (numberb fix) 3))
+
+;;; Then we define a teardown method, which should return the instance
+;;; to it's original form and reset the environment. In this case
+;;; there is little for us to do since the fixture is quite static.
+;;; In other cases we may need to clear some database tables, or
+;;; otherwise get rid of state built up while perofmring the test.
+;;; Here we just return T.
+
+(defmethod teardown ((fix math-fixture))
+ t)
+
+;;; Once we hav a fixture we can start defining method on it which
+;;; will perform tests. These methods should take one argument, an
+;;; instance of the fixture. The method performs some operation and
+;;; then performs some tests to determine if the proper behavior
+;;; occured. If there is a failure to behave as excpeted the method
+;;; raises a test-failure object by calling the method FAILURE. This
+;;; is much like calling ERROR in that it stops processing that
+;;; method. Each method should only check for one aspect of behavior.
+;;; This way triggering one failure would not result in another
+;;; behavior check from being skipped. It does not matter what these
+;;; methods return
+
+(defmethod addition-test ((test math-fixture))
+ (let ((result (+ (numbera test) (numberb test))))
+ (unless (= result 5)
+ (failure "Result was not 5 when adding ~A and ~A"
+ (numbera test) (numberb test)))))
+
+(defmethod subtraction-test ((test math-fixture))
+ (let ((result (- (numberb test) (numbera test))))
+ (unless (= result 1)
+ (failure "Result was not 1 when subtracting ~A ~A"
+ (numberb test) (numbera test)))))
+
+;;; This method is meant to signal a failure
+(defmethod subtraction-test2 ((test math-fixture))
+ (let ((result (- (numbera test) (numberb test))))
+ (unless (= result 1)
+ (failure "Result was not 1 when subtracting ~A ~A"
+ (numbera test) (numberb test)))))
+
+
+;;; Now we can create a test-suite. A test-suite contains a group of
+;;; test-cases (instances of test-fixture) and/or other test-suites.
+;;; We can specify which tests are in a test-suite when we define the
+;;; test-suite, or we can add them later. See the documentation and
+;;; argument list for make-test-case for details on how to specify a
+;;; test-case.
+
+(setf math-test-suite (make-test-suite
+ "Math Test Suite"
+ "Simple test suite for arithmetic operators."
+ ("Addition Test" 'math-fixture
+ :test-thunk 'addition-test
+ :description "A simple test of the + operator")
+ ("Subtraction Test" 'math-fixture
+ :test-thunk 'subtraction-test
+ :description "A simple test of the - operator")))
+
+(add-test (make-test-case "Substraction Test 2" 'math-fixture
+ :test-thunk 'subtraction-test2
+ :description "A broken substraction test, should fail.")
+ math-test-suite)
+
+;;;; Finally we can run our test suite and see how it performs.
+;;;; (report-result (run-test math-test-suite) :verbose t)
--- /dev/null
+;;; -*- Mode: Lisp -*-
+;;;; xptestsuite.lisp --- Test suite based on Extreme Programming
+;;;; Framework by Kent Beck
+;;;;
+;;;; Inspired by http://www.xprogramming.com/testfram.htm
+;;;;
+;;;; Author: Craig Brozefsky <craig@onshore.com>
+;;;; Put in public domain by onShore, Inc
+;;;;
+;;;; $Id: xptestsuite.lisp,v 1.1 2002/10/22 18:46:20 kevin Exp $
+
+(in-package :xp-test)
+
+(defclass test-fixture ()
+ ((test-thunk
+ :initarg :test-thunk
+ :reader test-thunk
+ :initform 'perform-test
+ :documentation
+ "A thunk or symbol which will be applied to this instance, a
+test-case, to perform that test-case. Defaults to 'perform-test")
+ (test-name
+ :initarg :test-name
+ :reader test-name
+ :documentation
+ "The name of this test-case, used in reports.")
+ (test-description
+ :initarg :description
+ :reader description
+ :documentation
+ "Short description of this test-case, uses in reports"))
+ (:documentation
+ "Base class for test-fixtures. Test-cases are instances of test-fixtures."))
+
+(defmethod setup ((test test-fixture))
+ "Method called before performing a test, should set up the
+environment the test-case needs to operate in."
+ t)
+
+(defmethod teardown ((test test-fixture))
+ "Method called after performing a test. Should reverse everything that the
+setup method did for this instance."
+ t)
+
+(define-condition test-failure (simple-condition) ()
+ (:documentation "Base class for all test failures."))
+
+(defun failure (format-str &rest args)
+ "Signal a test failure and exit the test."
+ (signal 'test-failure
+ #+(or cmu allegro) :format-control
+ #-(or cmu allegro) :format-string
+ format-str
+ :format-arguments args))
+
+(defmacro test-assert (test)
+ `(unless ,test
+ (failure "Test assertion failed: ~s" ',test)))
+
+
+(defmethod perform-test ((test test-fixture))
+ "Default method for performing tests upon a test-fixture."
+ t)
+
+(defmacro handler-case-if (test form &body cases)
+ `(if ,test
+ (handler-case
+ ,form
+ ,@cases)
+ ,form))
+
+(defmacro unwind-protect-if (test protected cleanup)
+ `(if ,test
+ (unwind-protect
+ ,protected
+ ,cleanup)
+ (progn ,protected ,cleanup)))
+
+(defmethod run-test ((test test-fixture) &key (handle-errors t))
+ "Perform the test represented by the given test-case or test-suite.
+Returns one or more test-result objects, one for each test-case
+performed."
+ (let ((start-time (get-universal-time))
+ (failures ())
+ (errs ()))
+ (unwind-protect-if handle-errors
+ (handler-case-if handle-errors
+ (let ((res (progn (setup test)
+ (apply (test-thunk test) (list test)))))
+ (if (typep res 'test-failure)
+ (setf failures (cons res failures))))
+ (test-failure (failure)
+ (setf failures (cons failure failures)))
+ (t (err)
+ (setf errs (cons err errs))))
+ (handler-case-if handle-errors
+ (teardown test)
+ (t (err)
+ (setf errs (cons err errs)))))
+ (make-instance 'test-result
+ :test test
+ :start-time start-time
+ :stop-time (get-universal-time)
+ :failures failures
+ :errors errs)))
+
+(defmacro def-test-fixture (name supers slotdefs &rest class-options)
+ "Define a new test-fixture class. Works just like defclass, but
+ensure that test-fixture is a super."
+ `(defclass ,name ,(append supers (list 'test-fixture))
+ ,slotdefs ,@class-options))
+
+(defmacro make-test-case (name fixture &key
+ (test-thunk 'perform-test)
+ (test-suite nil)
+ (description "No description."))
+ "Create a test-case which is an instance of FIXTURE. TEST-THUNK is
+the method that will be invoked when perfoming this test, and can be a
+symbol or a lambda taking a single argument, the test-fixture
+instance. DESCRIPTION is obviously what it says it is."
+ (let ((newtest (gensym "new-test")))
+ `(let ((,newtest (make-instance ,fixture
+ :test-name ,name
+ :test-thunk ,(if (eq test-thunk 'perform-test)
+ ''perform-test
+ test-thunk)
+ :description ,description)))
+ (if ,test-suite (add-test ,newtest ,test-suite))
+ ,newtest)))
+
+(defclass test-suite ()
+ ((name
+ :initarg :name
+ :reader test-suite-name)
+ (tests
+ :initarg :tests
+ :accessor tests-hash
+ :initform (make-hash-table :test 'equal))
+ (description
+ :initarg :description
+ :reader description
+ :initform "No description.")))
+
+(defmethod tests ((suite test-suite))
+ (let ((tlist nil))
+ (maphash #'(lambda (k v)
+ (declare (ignore k))
+ (setf tlist (cons v tlist)))
+ (tests-hash suite))
+ (reverse tlist)))
+
+(defmacro make-test-suite (name description &rest testspecs)
+ "Returns a new test-suite. TESTSPECS are just like lists of
+arguments to MAKE-TEST-CASE."
+ (let* ((newsuite (gensym "test-suite"))
+ (testforms (mapcar #'(lambda (spec)
+ (list
+ 'add-test
+ (cons 'make-test-case spec)
+ newsuite))
+ testspecs)))
+ `(let ((,newsuite (make-instance 'test-suite :name ,name
+ :description ,description)))
+ ,@testforms
+ ,newsuite)))
+
+(defmethod add-test ((test test-fixture) (suite test-suite))
+ (setf (gethash (test-name test) (tests-hash suite)) test))
+
+(defmethod add-test ((test test-suite) (suite test-suite))
+ (setf (gethash (test-suite-name test) (tests-hash suite)) test))
+
+(defmethod remove-test ((test test-fixture) (suite test-suite))
+ (remhash (test-name test) (tests-hash suite)))
+
+(defmethod remove-test ((test test-suite) (suite test-suite))
+ (remhash (test-suite-name test) (tests-hash suite)))
+
+(defmethod test-named ((name string) (suite test-suite))
+ (gethash name (tests-hash suite)))
+
+(defmethod setup-testsuite-named (name)
+ (declare (ignore name))
+ t)
+
+(defmethod teardown-testsuite-named (name)
+ (declare (ignore name))
+ t)
+
+(defmethod run-test ((suite test-suite) &key (handle-errors t))
+ (setup-testsuite-named (slot-value suite 'name))
+ (let ((res (mapcar (lambda (test) (run-test test
+ :handle-errors handle-errors))
+ (tests suite))))
+ (teardown-testsuite-named (slot-value suite 'name))
+ res))
+
+
+(defclass test-result ()
+ ((start-time
+ :initarg :start-time
+ :reader start-time)
+ (stop-time
+ :initarg :stop-time
+ :reader stop-time)
+ (test
+ :initarg :test
+ :reader result-test)
+ (failures
+ :initarg :failures
+ :reader test-failures
+ :initform nil)
+ (errors
+ :initarg :errors
+ :reader test-errors
+ :initform nil))
+ (:documentation
+ "The result of applying a test"))
+
+(defmethod report-result ((result test-result) &key (stream t) (verbose nil))
+ "Print out a test-result object for a report to STREAM, default to
+standard-output. If VERBOSE is non-nil then will produce a lengthy
+and informative report, otherwise just prints wether the test passed
+or failed or errored out."
+ (if verbose (format stream
+ "------------------------------------------------------~%"))
+ (format stream "Test ~A ~A ~%"
+ (test-name (result-test result))
+ (cond
+ ((test-failures result) "Failed")
+ ((test-errors result) "Errored")
+ (t "Passed")))
+ (if verbose
+ (progn
+ (format stream "Description: ~A~%" (description (result-test result)))
+ (if (test-failures result)
+ (progn
+ (format stream "Failures:~%")
+ (mapcar #'(lambda (fail) (format stream " ~A" fail))
+ (test-failures result))))
+ (if (test-errors result)
+ (progn
+ (format stream "Errors:~%")
+ (mapcar #'(lambda (fail) (format stream " ~A" fail))
+ (test-errors result))))))
+ (format stream "~%~%"))
+
+(defmethod report-result ((results list) &key (stream t) (verbose nil))
+ (dolist (foo results)
+ (report-result foo :stream stream :verbose verbose)))
+
+
+
+
+
+
+
projects / xptest.git / commitdiff