--- /dev/null
+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.
+
--- /dev/null
+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
--- /dev/null
+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 <luca@pca.it> 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 <luca@pca.it> Wed, 9 Mar 2005 15:48:07 +0100
+
--- /dev/null
+Source: fiveam
+Section: devel
+Priority: optional
+Maintainer: Luca Capello <luca@pca.it>
+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.
--- /dev/null
+This package was debianized by Luca Capello <luca@pca.it> 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 <mb@bese.it>
+
+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.
+
--- /dev/null
+#! /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:
+# * <postinst> `configure' <most-recently-configured-version>
+# * <old-postinst> `abort-upgrade' <new version>
+# * <conflictor's-postinst> `abort-remove' `in-favour' <package>
+# <new-version>
+# * <deconfigured's-postinst> `abort-deconfigure' `in-favour'
+# <failed-install-package> <version> `removing'
+# <conflicting-package> <version>
+# 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
--- /dev/null
+#! /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:
+# * <prerm> `remove'
+# * <old-prerm> `upgrade' <new-version>
+# * <new-prerm> `failed-upgrade' <old-version>
+# * <conflictor's-prerm> `remove' `in-favour' <package> <new-version>
+# * <deconfigured's-prerm> `deconfigure' `in-favour'
+# <package-being-installed> <version> `removing'
+# <conflicting-package> <version>
+# 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
--- /dev/null
+#!/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
--- /dev/null
+;;;; -*- lisp -*-
+
+(defpackage :it.bese.FiveAM.system
+ (:use :common-lisp
+ :asdf))
+
+(in-package :it.bese.FiveAM.system)
+
+(defsystem :FiveAM
+ :author "Edward Marco Baringer <mb@bese.it>"
+ :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))
--- /dev/null
+;; -*- 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
--- /dev/null
+;; -*- 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
--- /dev/null
+;; -*- 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
--- /dev/null
+;; -*- 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.
--- /dev/null
+;; -*- 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
+;;;; <mb@bese.it> 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
--- /dev/null
+;; -*- 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 "~@<Rerun the test ~S~@:>" test))
+ (%run test))
+ (ignore ()
+ :report (lambda (stream)
+ (format stream "~@<Signal a test failure and abort the test ~S.~@:>" 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.
--- /dev/null
+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; }
--- /dev/null
+;; -*- 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
--- /dev/null
+;; -*- 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.
--- /dev/null
+;;;; -*- 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))))
--- /dev/null
+;;;; -*- lisp -*-
+
+(in-package :it.bese.fiveam)
+
+(unless (get-test :it.bese)
+ (def-suite :it.bese))
+
+(def-suite :it.bese.fiveam :in :it.bese)
--- /dev/null
+;;;; -*- 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)))
projects / fiveam.git / commitdiff