From 811f8c443ebbc85bab095bfd75db974f6dd52ae8 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Tue, 22 Oct 2002 18:46:20 +0000 Subject: [PATCH] r3144: *** empty log message *** --- COPYING | 6 ++ Makefile | 17 +++ README | 36 +++++++ XPTest.system | 31 ++++++ package.lisp | 38 +++++++ xptest-example.lisp | 95 ++++++++++++++++ xptestsuite.lisp | 257 ++++++++++++++++++++++++++++++++++++++++++++ 7 files changed, 480 insertions(+) create mode 100644 COPYING create mode 100644 Makefile create mode 100644 README create mode 100644 XPTest.system create mode 100644 package.lisp create mode 100644 xptest-example.lisp create mode 100644 xptestsuite.lisp diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..abff616 --- /dev/null +++ b/COPYING @@ -0,0 +1,6 @@ +This code has been put into the public domain by onShore Development +Inc, and it's primary author Craig Brozefsky. + +However, we would appreciate it if improvements and modifications were +contributed back to the project so that everyone can share in them. + diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..d69f410 --- /dev/null +++ b/Makefile @@ -0,0 +1,17 @@ +# -*- Mode: Makefile -*- +# $Id: Makefile,v 1.1 2002/10/22 18:46:20 kevin Exp $ + +# Top Level Makefile for xptest + +.PHONY: wwwdist +wwwdist: + @echo "nothing to be done for $@" + +.PHONY: clean +clean: + rm -f *.x86f *.sparcf *.fasl *.err + +.PHONY: distclean +distclean: clean + rm -f *~ *.bak .\#* \#* + diff --git a/README b/README new file mode 100644 index 0000000..f1b45c4 --- /dev/null +++ b/README @@ -0,0 +1,36 @@ +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 . Any bug +reports, comments, or patches can be sent to him. + +Others who have contributed: +Lyn Headley +Stig Erik Sandoe \ No newline at end of file diff --git a/XPTest.system b/XPTest.system new file mode 100644 index 0000000..7ba8976 --- /dev/null +++ b/XPTest.system @@ -0,0 +1,31 @@ +;;; -*- Mode: Lisp -*- +;;;; XPTest --- XP Test Framework, inspired by Kent Beck +;;;; +;;;; Put in public domain by onShore, Inc. +;;;; +;;;; XPTest.system --- system definition for XPTest +;;;; +;;;; Checkout Tag: $Name: $ +;;;; $Id: XPTest.system,v 1.1 2002/10/22 18:46:20 kevin Exp $ + +#+CLISP +(in-package "USER") +#-CLISP +(in-package :CL-USER) + +;;; System definition + +(mk:defsystem "XPTest" + :source-pathname "systems:xptest;" + :source-extension "lisp" + :binary-pathname nil + :binary-extension nil + :components ((:file "package") + (:file "xptestsuite" + :depends-on ("package")) + (:file "xptest-example" + :depends-on ("xptestsuite"))) + ) + + + diff --git a/package.lisp b/package.lisp new file mode 100644 index 0000000..f94d963 --- /dev/null +++ b/package.lisp @@ -0,0 +1,38 @@ +;;; -*- Syntax: Ansi-Common-Lisp; Base: 10; Mode: lisp; Package: cl-user -*- +;;; $Id: package.lisp,v 1.1 2002/10/22 18:46:20 kevin Exp $ + +(in-package :cl-user) + +(eval-when (:compile-toplevel :load-toplevel :execute) + + (defpackage :xp-test-framework + (:use #:common-lisp) + (:nicknames #:xp-test #:xptest) + (:export + ;;; Framework classes + #:setup + #:teardown + #:perform-test + #:test-failure + #:failure + #:run-test + #:def-test-fixture + #:make-test-case + #:make-test-suite + #:setup-testsuite-named + #:teardown-testsuite-named + #:add-test + #:test-named + #:remove-test + #:tests + #:test-result + #:report-result + ) + (:documentation "This is the XP TestSuite Framework.")) + + (defpackage :xp-test-example + (:use #:common-lisp #:xp-test) + (:export + #:math-test-suite)) + ) + diff --git a/xptest-example.lisp b/xptest-example.lisp new file mode 100644 index 0000000..9700db2 --- /dev/null +++ b/xptest-example.lisp @@ -0,0 +1,95 @@ +;;; -*- Mode: Lisp -*- +;;;; xptest-eaxmple.lisp --- Example of test suite based on Extreme +;;;; Programming Framework by Kent Beck +;;;; +;;;; Author: Craig Brozefsky +;;;; 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) diff --git a/xptestsuite.lisp b/xptestsuite.lisp new file mode 100644 index 0000000..0ac9f49 --- /dev/null +++ b/xptestsuite.lisp @@ -0,0 +1,257 @@ +;;; -*- 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 +;;;; 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))) + + + + + + + -- 2.34.1