From: Marco Baringer Date: Wed, 20 Jul 2005 08:43:55 +0000 (+0200) Subject: Initial import of FiveAM code. This is exactly equal to to bese-2004@common-lisp... X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=1454981ac5f4f7ea8fe741a8125efbf0b09497ea;p=fiveam.git Initial import of FiveAM code. This is exactly equal to to bese-2004@common-lisp.net/FiveAM--dev--1.2--patch-20 --- diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..1d9e210 --- /dev/null +++ b/COPYING @@ -0,0 +1,30 @@ +Copyright (c) 2003-2005, Edward Marco Baringer +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +- Redistributions of source code must retain the above copyright +notice, this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +- Neither the name of Edward Marco Baringer, nor BESE, nor the names +of its contributors may be used to endorse or promote products derived +from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/README b/README new file mode 100644 index 0000000..1584f4f --- /dev/null +++ b/README @@ -0,0 +1,9 @@ +This is FiveAM, a common lisp testing framework. + +The documentation can be found in the docstrings, start with the +package :it.bese.fiveam (nicknamed 5AM). + +The mailing list for FiveAM is bese-devel@common-lisp.net (the list is +shared with arnesi, yaclml and ucw). + +All the code is Copyright (C) 2002-2005 Edward Marco Baringer. \ No newline at end of file diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 0000000..632ae0c --- /dev/null +++ b/debian/changelog @@ -0,0 +1,19 @@ +fiveam (1.2.3+tla20050331-1) unstable; urgency=low + + * debian/control: + * suggests latex for the documentation + * debian/rules: + * added command to delete the .arch-ids folders + * arch revision: + FiveAM--dev--1.2--patch-16 + + -- Luca Capello Thu, 31 Mar 2005 15:45:58 +0200 + +fiveam (1.2.3+tla20050309) unstable; urgency=low + + * Initial release + * arch revision: + FiveAM--dev--1.2--patch-13 + + -- Luca Capello Wed, 9 Mar 2005 15:48:07 +0100 + diff --git a/debian/control b/debian/control new file mode 100644 index 0000000..d94530b --- /dev/null +++ b/debian/control @@ -0,0 +1,21 @@ +Source: fiveam +Section: devel +Priority: optional +Maintainer: Luca Capello +Build-Depends: debhelper (>= 4.0.0) +Standards-Version: 3.6.1 + +Package: cl-fiveam +Architecture: all +Depends: ${shlibs:Depends}, ${misc:Depends}, common-lisp-controller (>= 3.47), cl-asdf, cl-arnesi +Suggests: latex +Description: simple regression testing framework + FiveAM is a simple (as far as writing and running tests goes) + regression testing framework. It has been designed with Common + Lisp's interactive development model in mind. + . + Features: + * Test and test suite hierarchies allow test to be organized into + hierarchies to ease running + * Functions for re-running recently run tests. + * Inter-test dependencies. diff --git a/debian/copyright b/debian/copyright new file mode 100644 index 0000000..de1a76f --- /dev/null +++ b/debian/copyright @@ -0,0 +1,17 @@ +This package was debianized by Luca Capello on +Mon, 7 Mar 2005 15:37:57 +0100. + +It was downloaded from http://common-lisp.net/project/bese/FiveAM.html + +Upstream Author: Edward Marco Baringer + +Copyright; + +This software is licensed under the terms of the BSD license, +which can be found on Debian systems in the file +/usr/share/common-licenses/BSD or from +http://www.opensource.org/licenses/bsd-license.php + +The license was modified to reflect that Edward Marco Baringer, +not the Regents of the University of California, is the author. + diff --git a/debian/postinst b/debian/postinst new file mode 100755 index 0000000..b765173 --- /dev/null +++ b/debian/postinst @@ -0,0 +1,48 @@ +#! /bin/sh +# postinst script for cl-fiveam +# +# see: dh_installdeb(1) + +set -e + +# package name according to lisp +LISP_CL_SHARE=/usr/share/common-lisp +LISP_PKG=fiveam +LISP_PKG_SOURCE=${LISP_CL_SHARE}/source/${LISP_PKG} + +# summary of how this script can be called: +# * `configure' +# * `abort-upgrade' +# * `abort-remove' `in-favour' +# +# * `abort-deconfigure' `in-favour' +# `removing' +# +# for details, see http://www.debian.org/doc/debian-policy/ or +# the debian-policy package +# +# quoting from the policy: +# Any necessary prompting should almost always be confined to the +# post-installation script, and should be protected with a conditional +# so that unnecessary prompting doesn't happen if a package's +# installation fails and the `postinst' is called with `abort-upgrade', +# `abort-remove' or `abort-deconfigure'. + +case "$1" in + configure) + /usr/sbin/register-common-lisp-source ${LISP_PKG} + ;; + abort-upgrade|abort-remove|abort-deconfigure) + ;; + *) + echo "postinst called with unknown argument \`$1'" >&2 + exit 1 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 diff --git a/debian/prerm b/debian/prerm new file mode 100755 index 0000000..3e3eb78 --- /dev/null +++ b/debian/prerm @@ -0,0 +1,42 @@ +#! /bin/sh +# prerm script for cl-fiveam +# +# see: dh_installdeb(1) + +set -e + +# package name according to lisp +LISP_CL_SHARE=/usr/share/common-lisp +LISP_PKG=fiveam +LISP_PKG_SOURCE=${LISP_CL_SHARE}/source/${LISP_PKG} + +# summary of how this script can be called: +# * `remove' +# * `upgrade' +# * `failed-upgrade' +# * `remove' `in-favour' +# * `deconfigure' `in-favour' +# `removing' +# +# for details, see http://www.debian.org/doc/debian-policy/ or +# the debian-policy package + + +case "$1" in + remove|upgrade|deconfigure) + /usr/sbin/unregister-common-lisp-source ${LISP_PKG} + ;; + failed-upgrade) + ;; + *) + echo "prerm called with unknown argument \`$1'" >&2 + exit 1 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 diff --git a/debian/rules b/debian/rules new file mode 100755 index 0000000..76fea2a --- /dev/null +++ b/debian/rules @@ -0,0 +1,71 @@ +#!/usr/bin/make -f + +export DH_COMPAT=4 + +pkg := fiveam +debpkg := cl-$(pkg) + + +clc-source := usr/share/common-lisp/source +clc-systems := usr/share/common-lisp/systems +clc-files := $(clc-source)/$(pkg) +doc-dir := usr/share/doc/$(debpkg) + + +configure: configure-stamp + +configure-stamp: + dh_testdir + # Add here commands to configure the package. +# touch configure-stamp + +build: build-stamp + +build-stamp: configure-stamp + dh_testdir + # Add here commands to compile the package. +# touch build-stamp + +clean: + dh_testdir + dh_testroot + rm -f build-stamp configure-stamp + # Add here commands to clean up after the build process. + rm -rf debian/postinst.* debian/prerm.* debian/$(debpkg) + dh_clean + +install: build + dh_testdir + dh_testroot + dh_clean -k + # Add here commands to install the package into debian/pkg. + dh_installdirs + + # Install sources + dh_install $(pkg).asd $(clc-files) + cp -r src debian/$(debpkg)/$(clc-files) + cp -r t debian/$(debpkg)/$(clc-files) + find debian/$(debpkg)/$(clc-files) -name .arch-ids | xargs rm -r + dh_link $(clc-files)/$(pkg).asd $(clc-systems)/$(pkg).asd + +# Build architecture-independent files here. +binary-indep: build install + +binary-arch: build install + dh_testdir + dh_testroot + dh_installdocs README + dh_installchangelogs +# dh_installemacsen +# dh_installexamples + dh_strip + dh_compress + dh_fixperms + dh_installdeb + dh_shlibdeps + dh_gencontrol + dh_md5sums + dh_builddeb + +binary: binary-indep binary-arch +.PHONY: build clean binary-indep binary-arch binary install configure diff --git a/fiveam.asd b/fiveam.asd new file mode 100644 index 0000000..c273caa --- /dev/null +++ b/fiveam.asd @@ -0,0 +1,29 @@ +;;;; -*- lisp -*- + +(defpackage :it.bese.FiveAM.system + (:use :common-lisp + :asdf)) + +(in-package :it.bese.FiveAM.system) + +(defsystem :FiveAM + :author "Edward Marco Baringer " + :properties ((:test-suite-name . :it.bese.fiveam)) + :components ((:static-file "fiveam.asd") + (:module :src + :components ((:file "check" :depends-on ("packages")) + (:file "classes" :depends-on ("packages")) + (:file "explain" :depends-on ("classes" "packages" "check")) + (:file "fixture" :depends-on ("packages")) + (:file "packages") + (:file "run" :depends-on ("packages" "classes" "test" "suite" "check")) + (:file "suite" :depends-on ("packages" "test" "classes")) + (:file "test" :depends-on ("packages" "classes")))) + (:module :t + :components ((:file "suite") + (:file "tests" :depends-on ("suite"))) + :depends-on (:src))) + :depends-on (:arnesi)) + +(defmethod asdf:perform ((op asdf:test-op) (system (eql (find-system :FiveAM)))) + (funcall (intern (string :run!) (string :it.bese.FiveAM)) :it.bese.FiveAM)) diff --git a/src/check.lisp b/src/check.lisp new file mode 100644 index 0000000..f5162f0 --- /dev/null +++ b/src/check.lisp @@ -0,0 +1,225 @@ +;; -*- lisp -*- + +(in-package :it.bese.FiveAM) + +;;;; * Checks + +;;;; At the lowest level testing the system requires that certain +;;;; forms be evaluated and that certain post conditions are met: the +;;;; value returned must satisfy a certain predicate, the form must +;;;; (or must not) signal a certain condition, etc. In FiveAM these +;;;; low level operations are called 'checks' and are defined using +;;;; the various checking macros. + +;;;; Checks are the basic operators for collecting results. Tests and +;;;; test suites on the other hand allow grouping multiple checks into +;;;; logic collections. + +(defvar *test-dribble* t) + +(defmacro with-*test-dribble* (stream &body body) + `(let ((*test-dribble* ,stream)) + (declare (special *test-dribble*)) + ,@body)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (def-special-environment run-state () + result-list + current-test)) + +;;;; ** Types of test results + +;;;; Every check produces a result object. + +(defclass test-result () + ((reason :accessor reason :initarg :reason :initform "no reason given") + (test-case :accessor test-case :initarg :test-case)) + (:documentation "All checking macros will generate an object of + type TEST-RESULT.")) + +(defclass test-passed (test-result) + () + (:documentation "Class for successful checks.")) + +(defgeneric test-passed-p (object) + (:method ((o t)) nil) + (:method ((o test-passed)) t)) + +(defclass test-failure (test-result) + () + (:documentation "Class for unsuccessful checks.")) + +(defgeneric test-failure-p (object) + (:method ((o t)) nil) + (:method ((o test-failure)) t)) + +(defclass unexpected-test-failure (test-failure) + ((actual-condition :accessor actual-condition :initarg :condition)) + (:documentation "Represents the result of a test which neither +passed nor failed, but signaled an error we couldn't deal +with. + +Note: This is very different than a SIGNALS check which instead +creates a TEST-PASSED or TEST-FAILURE object.")) + +(defclass test-skipped (test-result) + () + (:documentation "A test which was not run. Usually this is due +to unsatisfied dependencies, but users can decide to skip test +when appropiate.")) + +(defgeneric test-skipped-p (object) + (:method ((o t)) nil) + (:method ((o test-skipped)) t)) + +(defun add-result (result-type &rest make-instance-args) + "Create a TEST-RESULT object of type RESULT-TYPE passing it the + initialize args MAKE-INSTANCE-ARGS and adds the resulting + object to the list of test results." + (with-run-state (result-list current-test) + (let ((result (apply #'make-instance result-type (append make-instance-args (list :test-case current-test))))) + (etypecase result + (test-passed (format *test-dribble* ".")) + (test-failure (format *test-dribble* "f")) + (test-skipped (format *test-dribble* "s"))) + (push result result-list)))) + +;;;; ** The check operators + +;;;; *** The IS check + +(defmacro is (test &rest reason-args) + "The DWIM checking operator. + +If TEST returns a true value a test-passed result is generated, +otherwise a test-failure result is generated and the reason, +unless REASON-ARGS is provided, is generated based on the form of +TEST: + + (predicate expected actual) - Means that we want to check + whether, according to PREDICATE, the ACTUAL value is + in fact what we EXPECTED. + + (predicate value) - Means that we want to ensure that VALUE + satisfies PREDICATE. + +Wrapping the TEST form in a NOT simply preducse a negated reason string." + (assert (listp test) + (test) + "Argument to IS must be a list, not ~S" test) + `(if ,test + (add-result 'test-passed) + (add-result 'test-failure + :reason ,(if (null reason-args) + (list-match-case test + ((not (?predicate ?expected ?actual)) + `(format nil "~S was ~S to ~S" ,?actual ',?predicate ,?expected)) + ((not (?satisfies ?value)) + `(format nil "~S satisfied ~S" ,?value ',?satisfies)) + ((?predicate ?expected ?actual) + `(format nil "~S was not ~S to ~S" ,?actual ',?predicate ,?expected)) + ((?satisfies ?value) + `(format nil "~S did not satisfy ~S" ,?value ',?satisfies)) + (t + `(is-true ,test ,@reason-args))) + `(format nil ,@reason-args))))) + +;;;; *** Other checks + +(defmacro skip (&rest reason) + "Generates a TEST-SKIPPED result." + `(progn + (format *test-dribble* "s") + (add-result 'test-skipped :reason (format nil ,@reason)))) + +(defmacro is-true (condition &rest reason-args) + "Like IS this check generates a pass if CONDITION returns true + and a failure if CONDITION returns false. Unlike IS this check + does not inspect CONDITION to determine how to report the + failure." + `(if ,condition + (add-result 'test-passed) + (add-result 'test-failure :reason ,(if reason-args + `(format nil ,@reason-args) + `(format nil "~S did not return a true value" ',condition))))) + +(defmacro is-false (condition &rest reason-args) + "Generates a pass if CONDITION returns false, generates a + failure otherwise. Like IS-TRUE, and unlike IS, IS-FALSE does + not inspect CONDITION to determine what reason to give it case + of test failure" + `(if ,condition + (add-result 'test-failure :reason ,(if reason-args + `(format nil ,@reason-args) + `(format nil "~S returned a true value" ',condition))) + (add-result 'test-passed))) + +(defmacro signals (condition &body body) + "Generates a pass if BODY signals a condition of type +CONDITION. BODY is evaluated in a block named NIL, CONDITION is +not evaluated." + (let ((block-name (gensym))) + `(block ,block-name + (handler-bind ((,condition (lambda (c) + (declare (ignore c)) + ;; ok, body threw condition + (add-result 'test-passed) + (return-from ,block-name t)))) + (block nil + ,@body + (add-result 'test-failure :reason (format nil "Failed to signal a ~S" ',condition)) + (return-from ,block-name nil)))))) + +(defmacro finishes (&body body) + "Generates a pass if BODY executes to normal completion. In +other words if body does signal, return-from or throw this test +fails." + `(let ((ok nil)) + (unwind-protect + (progn + ,@body + (setf ok t)) + (if ok + (add-result 'test-passed) + (add-result 'test-failure + :reason (format nil "Test didn't finish")))))) + +(defmacro pass (&rest message-args) + "Simply generate a PASS." + `(add-result 'test-passed ,@(when message-args + `(:reason (format nil ,@message-args))))) + +(defmacro fail (&rest message-args) + "Simply generate a FAIL." + `(add-result 'test-failure ,@(when message-args + `(:reason (format nil ,@message-args))))) + +;; Copyright (c) 2002-2003, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE diff --git a/src/classes.lisp b/src/classes.lisp new file mode 100644 index 0000000..ada97da --- /dev/null +++ b/src/classes.lisp @@ -0,0 +1,115 @@ +;; -*- lisp -*- + +(in-package :it.bese.FiveAM) + +(defclass testable-object () + ((name :initarg :name :accessor name + :documentation "A symbol naming this test object.") + (description :initarg :description :accessor description :initform nil + :documentation "The textual description of this test object.") + (depends-on :initarg :depends-on :accessor depends-on :initform nil + :documentation "The list of AND, OR, NOT forms specifying when to run this test.") + (status :initarg :status :accessor status :initform :unknown + :documentation "A symbol specifying the current status + of this test. Either: T - this test (and all its + dependencies, have passed. NIL - this test + failed (either it failed or its dependecies weren't + met. :circular this test has a circular depenedency + and was skipped."))) + +(defmethod print-object ((test testable-object) stream) + (print-unreadable-object (test stream :type t :identity t) + (format stream "~S" (name test)))) + +(defclass test-suite (testable-object) + ((tests :accessor tests :initform (make-hash-table :test 'eql) + :documentation "The hash table mapping names to test + objects in this suite. The values in this hash table + can be eitehr test-cases of other test-suites.")) + (:documentation "A test suite is a collection of tests or test suites. + +Test suites serve to organize tests into groups so that the +developer can chose to run some tests and not just one or +all. Like tests test suites have a name and a description. + +Test suites, like tests, can be part of other test suites, this +allows the developer to create a hierarchy of tests where sub +trees can be singularly run. + +Running a test suite has the effect of running every test (or +suite) in the suite.")) + +(defclass test-case (testable-object) + ((test-lambda :initarg :test-lambda :accessor test-lambda + :documentation "The function to run.")) + (:documentation "A test case is a single, named, collection of +checks. + +A test case is the smallest organizational element which can be +run individually. Every test case has a name, which is a symbol, +a description and a test lambda. The test lambda is a regular +funcall'able function which should use the various checking +macros to collect results. + +Every test case is part of a suite, when a suite is not +explicitly specified (either via the :SUITE parameter to the TEST +macro or the global variable *SUITE*) the test is inserted into +the global suite named NIL. + +Sometimes we want to run a certain test only if another test has +passed. FiveAM allows us to specify the ways in which one test is +dependent on another. + +- AND Run this test only if all the named tests passed. + +- OR Run this test if at least one of the named tests passed. + +- NOT Run this test only if another test has failed. + +FiveAM considers a test to have passed if all the checks executed +were successful, otherwise we consider the test a failure. + +When a test is not run due to it's dependencies having failed a +test-skipped result is added to the results.")) + +(defclass explainer () + ()) + +(defclass text-explainer (explainer) + ()) + +(defclass simple-text-explainer (text-explainer) + ()) + +(defclass detailed-text-explainer (text-explainer) + ()) + +;; Copyright (c) 2002-2003, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE diff --git a/src/explain.lisp b/src/explain.lisp new file mode 100644 index 0000000..4e23e0e --- /dev/null +++ b/src/explain.lisp @@ -0,0 +1,115 @@ +;; -*- lisp -*- + +(in-package :it.bese.FiveAM) + +;;;; * Analyzing the results + +;;;; Just as important as defining and runnig the tests is +;;;; understanding the results. FiveAM provides the function EXPLAIN +;;;; which prints a human readable summary (number passed, number +;;;; failed, what failed and why, etc.) of a list of test results. + +(defmethod explain ((exp detailed-text-explainer) results &optional (stream *test-dribble*)) + "Given a list of test results report write to stream detailed + human readable statistics regarding the results." + (multiple-value-bind (num-checks passed num-passed passed% + skipped num-skipped skipped% + failed num-failed failed% + unknown num-unknown unknown%) + (partition-results results) + (declare (ignore passed)) + (when (zerop num-checks) + (format stream "~%Didn't run anything...huh?") + (return-from explain nil)) + (format stream "~%Did ~D check~P.~%" + num-checks num-checks) + (format stream " Pass: ~D (~2D%)~%" num-passed passed%) + (format stream " Skip: ~D (~2D%)~%" num-skipped skipped%) + (format stream " Fail: ~D (~2D%)~%" num-failed failed%) + (when unknown + (format stream " UNKNOWN RESULTS: ~D (~2D)~%" num-unknown unknown%)) + (terpri stream) + (when failed + (format stream "Failure Details:~%") + (dolist (f failed) + (format stream "~A ~@{[~A]~}: ~%" + (name (test-case f)) + (description (test-case f))) + (format stream " ~A.~%" (reason f))) + (terpri stream)) + (when skipped + (format stream "Skip Details:~%") + (dolist (f skipped) + (format stream "~A ~@{[~A]~}: ~%" + (name (test-case f)) + (description (test-case f))) + (format stream " ~A.~%" (reason f))) + (terpri *test-dribble*)))) + +(defmethod explain ((exp simple-text-explainer) results &optional (stream *test-dribble*)) + (multiple-value-bind (num-checks passed num-passed passed% + skipped num-skipped skipped% + failed num-failed failed% + unknown num-unknown unknown%) + (partition-results results) + (declare (ignore passed passed% skipped skipped% failed failed% unknown unknown%)) + (format stream "~&Ran ~D checks, ~D passed" num-checks num-passed) + (when (plusp num-skipped) + (format stream ", ~D skipped " num-skipped)) + (format stream " and ~D failed.~%" num-failed) + (when (plusp num-unknown) + (format stream "~D UNKNOWN RESULTS.~%" num-unknown)))) + +(defun partition-results (results-list) + (let ((num-checks (length results-list))) + (destructuring-bind (passed skipped failed unknown) + (partitionx results-list + (lambda (res) + (typep res 'test-passed)) + (lambda (res) + (typep res 'test-skipped)) + (lambda (res) + (typep res 'test-failure)) + t) + (if (zerop num-checks) + (values 0 + nil 0 0 + nil 0 0 + nil 0 0 + nil 0 0) + (values + num-checks + passed (length passed) (floor (* 100 (/ (length passed) num-checks))) + skipped (length skipped) (floor (* 100 (/ (length skipped) num-checks))) + failed (length failed) (floor (* 100 (/ (length failed) num-checks))) + unknown (length unknown) (floor (* 100 (/ (length failed) num-checks)))))))) + +;; Copyright (c) 2002-2003, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE diff --git a/src/fixture.lisp b/src/fixture.lisp new file mode 100644 index 0000000..325933c --- /dev/null +++ b/src/fixture.lisp @@ -0,0 +1,68 @@ +;; -*- lisp -*- + +(in-package :it.bese.FiveAM) + +;;;; ** Fixtures + +;;;; When running tests we often need to setup some kind of context +;;;; (create dummy db connections, simulate an http request, +;;;; etc.). Fixtures provide a way to conviently hide this context +;;;; into a macro and allow the test to fuces on testing. + +;;;; NB: A FiveAM fixture is nothing more than a macro. Since the term +;;;; 'fixture' is so common in testing frameworks we've provided a +;;;; wrapper around defmacro for this purpose. + +(deflookup-table fixture + :documentation "Lookup table mapping fixture names to fixture + objects.") + +(defmacro def-fixture (name args &body body) + "Defines a fixture named NAME. A fixture is very much like a +macro but is used only for simple templating. A fixture created +with DEF-FIXTURE is a macro which can use the special macrolet +&BODY to specify where the body should go. + +See Also: WITH-FIXTURE +" + `(eval-when (:compile-toplevel :load-toplevel :execute) + (setf (get-fixture ',name) (cons ',args ',body)) + ',name)) + +(defmacro with-fixture (fixture-name args &body body) + "Insert BODY into the fixture named FIXTURE-NAME. + +See Also: DEF-FIXTURE" + (destructuring-bind (largs &rest lbody) (get-fixture fixture-name) + `(macrolet ((&body () '(progn ,@body))) + (funcall (lambda ,largs ,@lbody) ,@args)))) + +;; Copyright (c) 2002-2003, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/src/packages.lisp b/src/packages.lisp new file mode 100644 index 0000000..0a8b076 --- /dev/null +++ b/src/packages.lisp @@ -0,0 +1,130 @@ +;; -*- lisp -*- + +;;;; * Introduction + +;;;; FiveAM is A simple Common Lisp unit testing library. + +;;;; FiveAM is a testing framework. It takes care of all the boring +;;;; bookkeeping associated with managing a test framework allowing +;;;; the developer to focus on writing tests and code. + +;;;; FiveAM was designed with the following premises: + +;;;; - Defining tests should be about writing tests, not +;;;; infrastructure. The developer should be able to focus on what +;;;; they're testing, not the testing framework. + +;;;; - Interactive testing is the norm. Common Lisp is an interactive +;;;; development environment, the testing environment should allow +;;;; the developer to quickly and easily redefine, change, remove +;;;; and run tests. + +(defpackage :it.bese.FiveAM + (:use :common-lisp :it.bese.arnesi) + (:nicknames :5am) + (:export ;; creating tests and test-suites + #:make-suite + #:def-suite + #:in-suite + #:make-test + #:test + #:get-test + #:rem-test + ;; fixtures + #:make-fixture + #:def-fixture + #:with-fixture + #:get-fixture + #:rem-fixture + ;; running checks + #:is + #:is-true + #:is-false + #:signals + #:finishes + #:skip + #:pass + #:fail + #:*test-dribble* + ;; running tests + #:run + #:run-all-tests + #:explain + #:run! + #:! + #:!! + #:!!! + #:*debug-on-error*)) + +;;;;@include "check.lisp" + +;;;;@include "test.lisp" + +;;;;@include "fixture.lisp" + +;;;;@include "suite.lisp" + +;;;;@include "run.lisp" + +;;;;@include "explain.lisp" + +;;;; * Examples + +#| (def-suite my-suite :description "My Example Suite") + + (in-suite my-suite) + + (test my-tests + "Example" + (is (= 4 (+ 2 2)) "2 plus 2 wasn't equal to 4 (using #'= to test equality)") + (is (= 0 (+ -1 1))) + (throws (error "Trying to add 4 to FOO didn't signal an error") + (+ 'foo 4)) + (is (= 0 (+ 1 1)) "this should have failed")) + + (run! 'my-suite) +;; Running suite MY-SUITE +..F. +Suite My Example Suite ran 4 tests (3/0/1) - 1 FAILED - +Failed Tests: +MY-TESTS FAILED: (+ 1 1) was not = to 0 (returned 2 instead) + Description: Example. + Message: this should have failed +NIL |# + +;;;; * Colophon + +;;;; This documentaion was written by Edward Marco Baringer +;;;; and generated by qbook. + +;;;; ** COPYRIGHT + +;;;; Copyright (c) 2002-2003, Edward Marco Baringer +;;;; All rights reserved. + +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions are +;;;; met: + +;;;; - Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. + +;;;; - Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. + +;;;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;;;; of its contributors may be used to endorse or promote products +;;;; derived from this software without specific prior written permission. + +;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE diff --git a/src/run.lisp b/src/run.lisp new file mode 100644 index 0000000..2d1c898 --- /dev/null +++ b/src/run.lisp @@ -0,0 +1,254 @@ +;; -*- lisp -*- + +(in-package :it.bese.FiveAM) + +;;;; * Running Tests + +;;;; Once the programmer has defined what the tests are these need to +;;;; be run and the expected effects should be compared with the +;;;; actual effects. FiveAM provides the function RUN for this +;;;; purpose, RUN executes a number of tests and collects the results +;;;; of each individual check into a list which is then +;;;; returned. There are three types of test results: passed, failed +;;;; and skipped, these are represented by TEST-RESULT objects. + +;;;; Generally running a test will return normally, but there are two +;;;; exceptional situations which can occur: + +;;;; - An exception is signaled while running the test. If the +;;;; variable *debug-on-error* is T than FiveAM will enter the +;;;; debugger, otherwise a test failure (of type +;;;; unexpected-test-failure) is returned. When entering the +;;;; debugger two restarts are made available, one simply reruns the +;;;; current test and another signals a test-failure and continues +;;;; with the remaining tests. + +;;;; - A circular dependency is detected. An error is signaled and a +;;;; restart is made available which signals a test-skipped and +;;;; continues with the remaining tests. This restart also sets the +;;;; dependency status of the test to nil, so any tests which depend +;;;; on this one (even if the dependency is not circular) will be +;;;; skipped. + +;;;; The functions RUN!, !, !! and !!! are convenient wrappers around +;;;; RUN and EXPLAIN. + +(defparameter *debug-on-error* t + "T if we should drop into a debugger on error, NIL otherwise.") + +(defun import-testing-symbols (package-designator) + (import '(5am::is 5am::is-true 5am::is-false 5am::signals 5am::finishes) + package-designator)) + +(defparameter *run-queue* '() + "List of test waiting to be run.") + +(define-condition circular-dependency (error) + ((test-case :initarg :test-case)) + (:report (lambda (cd stream) + (format stream "A circular dependency wes detected in ~S." (slot-value cd 'test-case)))) + (:documentation "Condition signaled when a circular dependency +between test-cases has been detected.")) + +(defgeneric run-resolving-dependencies (test) + (:documentation "Given a dependency spec determine if the spec +is satisfied or not, this will generally involve running other +tests. If the dependency spec can be satisfied the test is alos +run.")) + +(defmethod run-resolving-dependencies ((test test-case)) + "Return true if this test, and its dependencies, are satisfied, + NIL otherwise." + (case (status test) + (:unknown + (setf (status test) :resolving) + (if (or (not (depends-on test)) + (resolve-dependencies (depends-on test))) + (progn + (run-test-lambda test) + (status test)) + (with-run-state (result-list) + (unless (eql :circular (status test)) + (push (make-instance 'test-skipped + :test-case test + :reason "Dependencies not satisfied") + result-list) + (setf (status test) :depends-not-satisfied))))) + (:resolving + (restart-case + (error 'circular-dependency :test-case test) + (skip () + :report (lambda (s) + (format s "Skip the test ~S and all its dependencies." (name test))) + (with-run-state (result-list) + (push (make-instance 'test-skipped :reason "Circular dependencies" :test-case test) + result-list)) + (setf (status test) :circular)))) + (t (status test)))) + +(defmethod resolve-dependencies ((depends-on symbol)) + "A test which depends on a symbol is interpreted as `(AND + ,DEPENDS-ON)." + (run-resolving-dependencies (get-test depends-on))) + +(defmethod resolve-dependencies ((depends-on list)) + "Return true if the dependency spec DEPENDS-ON is satisfied, + nil otherwise." + (if (null depends-on) + t + (flet ((satisfies-depends-p (test) + (funcall test (lambda (dep) + (eql t (resolve-dependencies dep))) + (cdr depends-on)))) + (ecase (car depends-on) + (and (satisfies-depends-p #'every)) + (or (satisfies-depends-p #'some)) + (not (satisfies-depends-p #'notany)))))) + +(defun handle-unexpected-error (test error) + "Handler for unexpected conditions raised during test + execution." + (when (not *debug-on-error*) + (format *test-dribble* "F") + (with-run-state (result-list) + (push (make-instance 'unexpected-test-failure + :test-case test + :reason (format nil "Unexpected Error: ~S." error) + :condition test) + result-list) + (throw 'run-block result-list)))) + +(defun results-status (result-list) + "Given a list of test results (generated while running a test) + return true if all of the results are of type TEST-PASSED, + faile otherwise." + (every (lambda (res) + (typep res 'test-passed)) + result-list)) + +(defun return-result-list (test-lambda) + "Run the test function TEST-LAMBDA and return a list of all + test results generated, does not modify the special environment + variable RESULT-LIST." + (bind-run-state ((result-list '())) + (funcall test-lambda) + result-list)) + +(defmethod run-test-lambda ((test test-case)) + (with-run-state (result-list) + (catch 'run-block + (bind-run-state ((current-test test)) + (handler-bind ((error (lambda (e) (handle-unexpected-error test e)))) + (restart-case + (let ((results (return-result-list (test-lambda test)))) + (setf (status test) (results-status results) + result-list (nconc result-list results))) + (retest () + :report (lambda (stream) + (format stream "~@" test)) + (%run test)) + (ignore () + :report (lambda (stream) + (format stream "~@" test)) + (push (make-instance 'test-failure :test-case test + :reason "Failure restart.") + result-list)))))))) + +(defgeneric %run (test-spec) + (:documentation "Internal method for running a test. Does not + update the status of the tests nor the special vairables !, + !!, !!!")) + +(defmethod %run ((test test-case)) + (run-resolving-dependencies test)) + +(defmethod %run ((suite test-suite)) + (let ((suite-results '())) + (bind-run-state ((result-list '())) + (loop for test being the hash-values of (tests suite) + do (%run test) + finally (setf suite-results result-list))) + (setf (status suite) (every (lambda (res) + (typep res 'test-passed)) + suite-results)) + (with-run-state (result-list) + (setf result-list (nconc result-list suite-results))))) + +(defmethod %run ((test-name symbol)) + (when-bind test (get-test test-name) + (%run test))) + +(defvar *initial-!* (lambda () (format t "Haven't run that many tests yet.~%"))) + +(defvar *!* *initial-!*) +(defvar *!!* *initial-!*) +(defvar *!!!* *initial-!*) + +;;;; ** Public entry points + +(defun run! (test-spec) + "Equivalent to (explain (run TEST-SPEC))." + (explain! (run test-spec))) + +(defun explain! (result-list) + "Explain the results of RESULT-LIST using a +detailed-text-explainer with output going to *test-dribble*" + (explain (make-instance 'detailed-text-explainer) result-list *test-dribble*)) + +(defun run (test-spec) + "Run the test specified by TEST-SPEC. + +TEST-SPEC can be either a symbol naming a test or test suite, or +a testable-object object. This function changes the operations +performed by the !, !! and !!! functions." + (psetf *!* (lambda () + (loop for test being the hash-keys of *test* + do (setf (status (get-test test)) :unknown)) + (bind-run-state ((result-list '())) + (%run test-spec) + result-list)) + *!!* *!* + *!!!* *!!*) + (funcall *!*)) + +(defun ! () + "Rerun the most recently run test and explain the results." + (explain! (funcall *!*))) + +(defun !! () + "Rerun the second most recently run test and explain the results." + (explain! (funcall *!!*))) + +(defun !!! () + "Rerun the third most recently run test and explain the results." + (explain! (funcall *!!!*))) + +;; Copyright (c) 2002-2003, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/src/style.css b/src/style.css new file mode 100644 index 0000000..4a1e601 --- /dev/null +++ b/src/style.css @@ -0,0 +1,64 @@ +body { + background-color: #FFFFFF; + color: #000000; + padding: 0px; margin: 0px; +} + +.qbook { width: 600px; background-color: #FFFFFF; margin: 0px; + border-left: 3em solid #660000; padding: 3px; } + +h1 { text-align: center; margin: 0px; + color: #333333; + border-bottom: 0.3em solid #660000; +} + +p { padding-left: 1em; } + +h2 { border-bottom: 0.2em solid #000000; font-family: verdana; } + +h3 { border-bottom: 0.1em solid #000000; } + +pre.code { + background-color: #eeeeee; + border: solid 1px #d0d0d0; + overflow: auto; +} + +pre.code * .paren { color: #666666; } + +pre.code a:active { color: #000000; } +pre.code a:link { color: #000000; } +pre.code a:visited { color: #000000; } + +pre.code .first-line { font-weight: bold; } + +div.contents { font-family: verdana; } + +div.contents a:active { color: #000000; } +div.contents a:link { color: #000000; } +div.contents a:visited { color: #000000; } + +div.contents div.contents-heading-1 { padding-left: 0.5em; font-weight: bold; } +div.contents div.contents-heading-1 a:active { color: #660000; } +div.contents div.contents-heading-1 a:link { color: #660000; } +div.contents div.contents-heading-1 a:visited { color: #660000; } + +div.contents div.contents-heading-2 { padding-left: 1.0em; } +div.contents div.contents-heading-2 a:active { color: #660000; } +div.contents div.contents-heading-2 a:link { color: #660000; } +div.contents div.contents-heading-2 a:visited { color: #660000; } + +div.contents div.contents-heading-3 { padding-left: 1.5em; } +div.contents div.contents-heading-3 a:active { color: #660000; } +div.contents div.contents-heading-3 a:link { color: #660000; } +div.contents div.contents-heading-3 a:visited { color: #660000; } + +div.contents div.contents-heading-4 { padding-left: 2em; } +div.contents div.contents-heading-4 a:active { color: #660000; } +div.contents div.contents-heading-4 a:link { color: #660000; } +div.contents div.contents-heading-4 a:visited { color: #660000; } + +div.contents div.contents-heading-5 { padding-left: 2.5em; } +div.contents div.contents-heading-5 a:active { color: #660000; } +div.contents div.contents-heading-5 a:link { color: #660000; } +div.contents div.contents-heading-5 a:visited { color: #660000; } diff --git a/src/suite.lisp b/src/suite.lisp new file mode 100644 index 0000000..64223e0 --- /dev/null +++ b/src/suite.lisp @@ -0,0 +1,97 @@ +;; -*- lisp -*- + +(in-package :it.bese.FiveAM) + +;;;; * Test Suites + +;;;; Test suites allow us to collect multiple tests into a single +;;;; object and run them all using asingle name. Test suites do not +;;;; affect teh way test are run northe way the results are handled, +;;;; they are simply a test organizing group. + +;;;; Test suites can contain both tests and other test suites. Running +;;;; a test suite causes all of its tests and test suites to be +;;;; run. Suites do not affect test dependencies, running a test suite +;;;; can cause tests which are not in the suite to be run. + +;;;; ** Creating Suits + +(defmacro def-suite (name &key description in) + "Define a new test-suite named NAME. + +IN (a symbol), if provided, causes this suite te be nested in the +suite named by IN." + `(progn + (make-suite ',name + ,@(when description `(:description ,description)) + ,@(when in `(:in ',in))) + ',name)) + +(defun make-suite (name &key description in) + "Create a new test suite object." + (let ((suite (make-instance 'test-suite :name name))) + (when description + (setf (description suite) description)) + (loop for i in (ensure-list in) + for in-suite = (get-test i) + do (progn + (when (null in-suite) + (cerror "Create a new suite named ~A." "Unknown suite ~A." i) + (setf (get-test in-suite) (make-suite i) + in-suite (get-test in-suite))) + (setf (gethash name (tests in-suite)) suite))) + (setf (get-test name) suite) + suite)) + +;;;; ** Managing the Current Suite + +(defvar *suite* (setf (get-test 'NIL) + (make-suite 'NIL :description "Global Suite")) + "The current test suite object") + +(defmacro in-suite (suite-name) + "Set the *suite* special variable so that all tests defined +after the execution of this form are, unless specified otherwise, +in the test-suite named SUITE-NAME. + +See also: DEF-SUITE *SUITE*" + (with-unique-names (suite) + `(progn + (if-bind ,suite (get-test ',suite-name) + (setf *suite* ,suite) + (progn + (cerror "Create a new suite named ~A." + "Unkown suite ~A." ',suite-name) + (setf (get-test ',suite-name) (make-suite ',suite-name) + *suite* (get-test ',suite-name)))) + ',suite-name))) + +;; Copyright (c) 2002-2003, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE diff --git a/src/test.lisp b/src/test.lisp new file mode 100644 index 0000000..82b0c6c --- /dev/null +++ b/src/test.lisp @@ -0,0 +1,93 @@ +;; -*- lisp -*- + +(in-package :it.bese.FiveAM) + +;;;; * Tests + +;;;; While executing checks and collecting the results is the core job +;;;; of a testing framework it is also important to be able to +;;;; organize checks into groups, FiveAM provides two mechanisms for +;;;; organizing checks: tests and test suites. A test is a named +;;;; collection of checks which can be run and a test suite is a named +;;;; collection of tests and test suites. + +(deflookup-table test + :documentation "Lookup table mapping test (and test suite) + names to objects.") + +(defmacro test (name &body body) + "Create a suite named NAME. If NAME is a list it must be of the +form: + + (name &key depends-on suite) + +NAME is the symbol which names the test. + +DEPENDS-ON is a list of the form: + + (AND . test-names) - This test is run only if all of the tests + in TEST-NAMES have passed, otherwise a single test-skipped + result is generated. + + (OR . test-names) - If any of TEST-NAMES has passed this test is + run, otherwise a test-skipped result is generated. + + (NOT test-name) - This is test is run only if TEST-NAME failed. + +AND, OR and NOT can be combined to produce complex dependencies. + +If DEPENDS-ON is a symbol it is interpreted as `(AND +,depends-on), this is accomadate the common case of one test +depending on another. + +SUITE defaults to the current value of *SUITE*." + (destructuring-bind (name &key depends-on (suite nil suite-supplied-p)) + (ensure-list name) + (let (lambda description) + (setf description (if (stringp (car body)) + (pop body) + "") + lambda body) + `(progn + (setf (get-test ',name) + (make-instance 'test-case + :name ',name + :test-lambda (lambda () ,@lambda) + :description ,description + :depends-on ',depends-on)) + ,(if suite-supplied-p + `(setf (gethash ',name (tests (get-test ',suite))) + ',name) + `(setf (gethash ',name (tests (or *suite* (get-test 'NIL)))) + ',name)) + ',name)))) + +;; Copyright (c) 2002-2003, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/t/example.lisp b/t/example.lisp new file mode 100644 index 0000000..6131c39 --- /dev/null +++ b/t/example.lisp @@ -0,0 +1,87 @@ +;;;; -*- lisp -*- + +(asdf:oos 'asdf:load-op :FiveAM) + +(defpackage :it.bese.FiveAM.example + (:use :common-lisp + :it.bese.FiveAM)) + +(in-package :it.bese.FiveAM.example) + +;;; First we need some functions to test. + +(defun add-2 (n) + (+ n 2)) + +(defun add-4 (n) + (+ n 4)) + +;;; Now we need to create a test which makes sure that add-2 and add-4 +;;; work as specified. + +;; we create a test named ADD-2 and supply a short description. +(test add-2 + "Test the ADD-2 function" ;; a short description + ;; the checks + (is (= 2 (add-2 0))) + (is (= 0 (add-2 -2)))) + +;; we can already run add-2. This will return the list of test +;; results, it should be a list of two test-passed objects. + +(run 'add-2) + +;; since we'd like to have some kind of readbale output we'll explain +;; the results + +(explain *) + +;; or we could do both at once: + +(run! 'add-2) + +;;; So now we've defined and run a single test. Since we plan on +;;; having more than one test and we'd like to run them together let's +;;; create a simple test suite. + +(def-suite example-suite :description "The example test suite.") + +;; we could explictly specify that every test we create is in the the +;; example-suite suite, but it's easier to just change the default +;; suite: + +(in-suite example-suite) + +;; now we'll create a new test for the add-4 function. + +(test add-4 + (is (= 0 (add-4 -4)))) + +;; now let's run the test + +(run! 'add-4) + +;; we can get the same effect by running the suite: + +(run! 'example-suite) + +;; since we'd like both add-2 and add-4 to be in the same suite, let's +;; redefine add-2 to be in this suite: + +(test add-2 "Test the ADD-2 function" + (is (= 2 (add-2 0))) + (is (= 0 (add-2 -2)))) + +;; now we can run the suite and we'll see that both add-2 and add-4 +;; have been run (we know this since we no get 4 checks as opposed to +;; 2 as before. + +(run! 'example-suite) + +;; Just for fun let's see what happens when a test fails. Again we'll +;; redefine add-2, but add in a third, failing, check: + +(test add-2 "Test the ADD-2 function" + (is (= 2 (add-2 0))) + (is (= 0 (add-2 -2))) + (is (= 0 (add-2 0)))) diff --git a/t/suite.lisp b/t/suite.lisp new file mode 100644 index 0000000..9db6578 --- /dev/null +++ b/t/suite.lisp @@ -0,0 +1,8 @@ +;;;; -*- lisp -*- + +(in-package :it.bese.fiveam) + +(unless (get-test :it.bese) + (def-suite :it.bese)) + +(def-suite :it.bese.fiveam :in :it.bese) diff --git a/t/tests.lisp b/t/tests.lisp new file mode 100644 index 0000000..ac2a606 --- /dev/null +++ b/t/tests.lisp @@ -0,0 +1,147 @@ +;;;; -*- lisp -*- + +(in-package :it.bese.FiveAM) + +(in-suite :it.bese.FiveAM) + +(def-suite test-suite :description "Suite for tests which should fail.") + +(defmacro with-test-results ((results test-name) &body body) + `(let ((,results (with-*test-dribble* nil (run ',test-name)))) + ,@body)) + +;;;; Test the checks + +(test (is1 :suite test-suite) + (is (plusp 1)) + (is (< 0 1)) + (is (not (plusp -1))) + (is (not (< 1 0))) + (is-true t) + (is-false nil)) + +(test (is2 :suite test-suite) + (is (plusp 0)) + (is (< 0 -1)) + (is (not (plusp 1))) + (is (not (< 0 1))) + (is-true nil) + (is-false t)) + +(test is + (with-test-results (results is1) + (is (= 6 (length results))) + (is (every #'test-passed-p results))) + (with-test-results (results is2) + (is (= 6 (length results))) + (is (every #'test-failure-p results)))) + +(test signals/finishes + (signals error + (error "an error")) + (finishes + (signals error + (error "an error")))) + +(test pass + (pass)) + +(test (fail1 :suite test-suite) + (fail "This is supposed to fail")) + +(test fail + (with-test-results (results fail1) + (is (= 1 (length results))) + (is (test-failure-p (first results))))) + +;;;; non top level checks + +(test foo-bar + (let ((state 0)) + (is (= 0 state)) + (is (= 1 (incf state))))) + +;;;; Test dependencies + +(test (ok :suite test-suite) + (pass)) + +(test (not-ok :suite test-suite) + (fail "This is supposed to fail.")) + +(test (and1 :depends-on (and ok not-ok) :suite test-suite) + (fail)) + +(test (and2 :depends-on (and ok) :suite test-suite) + (pass)) + +(test dep-and + (with-test-results (results and1) + (is (= 3 (length results))) + ;; we should have one skippedw one failed and one passed + (is (some #'test-passed-p results)) + (is (some #'test-skipped-p results)) + (is (some #'test-failure-p results))) + (with-test-results (results and2) + (is (= 2 (length results))) + (is (every #'test-passed-p results)))) + +(test (or1 :depends-on (or ok not-ok) :suite test-suite) + (pass)) + +(test (or2 :depends-on (or not-ok ok) :suite test-suite) + (pass)) + +(test dep-or + (with-test-results (results or1) + (is (= 2 (length results))) + (is (every #'test-passed-p results))) + (with-test-results (results or2) + (is (= 3 (length results))) + (is (= 2 (length (remove-if-not #'test-passed-p results)))))) + +(test (not1 :depends-on (not not-ok) :suite test-suite) + (pass)) + +(test (not2 :depends-on (not ok) :suite test-suite) + (fail)) + +(test not + (with-test-results (results not1) + (is (= 2 (length results))) + (is (some #'test-passed-p results)) + (is (some #'test-failure-p results))) + (with-test-results (results not2) + (is (= 2 (length results))) + (is (some #'test-passed-p results)) + (is (some #'test-skipped-p results)))) + +(test (nested-logic :depends-on (and ok (not not-ok) (not not-ok)) + :suite test-suite) + (pass)) + +(test dep-nested + (with-test-results (results nested-logic) + (is (= 3 (length results))) + (is (= 2 (length (remove-if-not #'test-passed-p results)))) + (is (= 1 (length (remove-if-not #'test-failure-p results)))))) + +(test (circular-0 :depends-on (and circular-1 circular-2 or1) + :suite test-suite) + (fail "we depend on a circular dependency, we should not be tested.")) + +(test (circular-1 :depends-on (and circular-2) + :suite test-suite) + (fail "we have a circular depednency, we should not be tested.")) + +(test (circular-2 :depends-on (and circular-1) + :suite test-suite) + (fail "we have a circular depednency, we should not be tested.")) + +(test circular + (signals circular-dependency + (run 'circular-0)) + (signals circular-dependency + (run 'circular-1)) + (signals circular-dependency + (run 'circular-2)))