Author: ksprotte
Date: Mon Feb 18 08:55:20 2008
New Revision: 2550
Added:
trunk/thirdparty/fiveam/
trunk/thirdparty/fiveam/COPYING
trunk/thirdparty/fiveam/README
trunk/thirdparty/fiveam/docs/
trunk/thirdparty/fiveam/docs/make-qbook.lisp
trunk/thirdparty/fiveam/fiveam.asd
trunk/thirdparty/fiveam/src/
trunk/thirdparty/fiveam/src/check.lisp
trunk/thirdparty/fiveam/src/classes.lisp
trunk/thirdparty/fiveam/src/explain.lisp
trunk/thirdparty/fiveam/src/fixture.lisp
trunk/thirdparty/fiveam/src/packages.lisp
trunk/thirdparty/fiveam/src/random.lisp
trunk/thirdparty/fiveam/src/run.lisp
trunk/thirdparty/fiveam/src/style.css
trunk/thirdparty/fiveam/src/suite.lisp
trunk/thirdparty/fiveam/src/test.lisp
trunk/thirdparty/fiveam/t/
trunk/thirdparty/fiveam/t/example.lisp
trunk/thirdparty/fiveam/t/suite.lisp
trunk/thirdparty/fiveam/t/tests.lisp
Log:
added fiveam
Added: trunk/thirdparty/fiveam/COPYING
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/COPYING Mon Feb 18 08:55:20 2008
@@ -0,0 +1,30 @@
+Copyright (c) 2003-2006, 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.
+
Added: trunk/thirdparty/fiveam/README
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/README Mon Feb 18 08:55:20 2008
@@ -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(a)common-lisp.net (the list is
+shared with arnesi, yaclml and ucw).
+
+All the code is Copyright (C) 2002-2006 Edward Marco Baringer.
\ No newline at end of file
Added: trunk/thirdparty/fiveam/docs/make-qbook.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/docs/make-qbook.lisp Mon Feb 18 08:55:20 2008
@@ -0,0 +1,13 @@
+(asdf:oos 'asdf:load-op :FiveAM)
+(asdf:oos 'asdf:load-op :qbook)
+
+(asdf:oos 'qbook:publish-op :FiveAM
+ :generator (make-instance 'qbook:html-generator
+ :title "FiveAM"
+ :output-directory
+ (merge-pathnames
+ (make-pathname :directory '(:relative "docs" "html"))
+ (asdf:component-pathname (asdf:find-system :FiveAM)))))
+
+
+
Added: trunk/thirdparty/fiveam/fiveam.asd
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/fiveam.asd Mon Feb 18 08:55:20 2008
@@ -0,0 +1,34 @@
+;; -*- lisp -*-
+
+(defpackage :it.bese.FiveAM.system
+ (:use :common-lisp
+ :asdf))
+
+(in-package :it.bese.FiveAM.system)
+
+(defsystem :FiveAM
+ :author "Edward Marco Baringer <mb(a)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 "random" :depends-on ("packages" "check"))
+ (: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))
+
+;;;;@include "src/packages.lisp"
+
+;;;;@include "t/example.lisp"
Added: trunk/thirdparty/fiveam/src/check.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/src/check.lisp Mon Feb 18 08:55:20 2008
@@ -0,0 +1,324 @@
+;; -*- 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)
+ (test-expr :accessor test-expr :initarg :test-expr))
+ (: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))
+
+(define-condition check-failure (error)
+ ((reason :accessor reason :initarg :reason :initform "no reason given")
+ (test-case :accessor test-case :initarg :test-case)
+ (test-expr :accessor test-expr :initarg :test-expr))
+ (:documentation "Signaled when a check fails.")
+ (:report (lambda (c stream)
+ (format stream "The following check failed: ~S~%~A."
+ (test-expr c)
+ (reason c)))))
+
+(defmacro process-failure (&rest args)
+ `(progn
+ (with-simple-restart (ignore-failure "Continue the test run.")
+ (error 'check-failure ,@args))
+ (add-result 'test-failure ,@args)))
+
+(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* "."))
+ (unexpected-test-failure (format *test-dribble* "X"))
+ (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. 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)
+ (let (bindings effective-test default-reason-args)
+ (with-unique-names (e a v)
+ (flet ((process-entry (predicate expected actual &optional negatedp)
+ ;; make sure EXPECTED is holding the entry that starts with 'values
+ (when (and (consp actual)
+ (eq (car actual) 'values))
+ (assert (not (and (consp expected)
+ (eq (car expected) 'values))) ()
+ "Both the expected and actual part is a values expression.")
+ (let ((tmp expected))
+ (setf expected actual
+ actual tmp)))
+ (let ((setf-forms))
+ (if (and (consp expected)
+ (eq (car expected) 'values))
+ (progn
+ (setf expected (copy-list expected))
+ (setf setf-forms (loop for cell = (rest expected) then (cdr cell)
+ for i from 0
+ while cell
+ when (eq (car cell) '*)
+ collect `(setf (elt ,a ,i) nil)
+ and do (setf (car cell) nil)))
+ (setf bindings (list (list e `(list ,@(rest expected)))
+ (list a `(multiple-value-list ,actual)))))
+ (setf bindings (list (list e expected)
+ (list a actual))))
+ (setf effective-test `(progn
+ ,@setf-forms
+ ,(if negatedp
+ `(not (,predicate ,e ,a))
+ `(,predicate ,e ,a)))))))
+ (list-match-case test
+ ((not (?predicate ?expected ?actual))
+ (process-entry ?predicate ?expected ?actual t)
+ (setf default-reason-args
+ (list "~S evaluated to ~S, which is ~S to ~S (it should not be)"
+ `',?actual a `',?predicate e)))
+ ((not (?satisfies ?value))
+ (setf bindings (list (list v ?value))
+ effective-test `(not (,?satisfies ,v))
+ default-reason-args
+ (list "~S evaluated to ~S, which satisfies ~S (it should not)"
+ `',?value v `',?satisfies)))
+ ((?predicate ?expected ?actual)
+ (process-entry ?predicate ?expected ?actual)
+ (setf default-reason-args
+ (list "~S evaluated to ~S, which is not ~S to ~S."
+ `',?actual a `',?predicate e)))
+ ((?satisfies ?value)
+ (setf bindings (list (list v ?value))
+ effective-test `(,?satisfies ,v)
+ default-reason-args
+ (list "~S evaluated to ~S, which does not satisfy ~S"
+ `',?value v `',?satisfies)))
+ (?_
+ (setf bindings '()
+ effective-test test
+ default-reason-args (list "~S was NIL." `',test)))))
+ `(let ,bindings
+ (if ,effective-test
+ (add-result 'test-passed :test-expr ',test)
+ (process-failure :reason (format nil ,@(or reason-args default-reason-args))
+ :test-expr ',test))))))
+
+;;;; *** 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-every (predicate &body clauses)
+ "The input is either a list of lists, or a list of pairs. Generates (is (,predicate ,expr ,value))
+ for each pair of elements or (is (,predicate ,expr ,value) ,@reason) for each list."
+ `(progn
+ ,@(if (every #'consp clauses)
+ (loop for (expected actual . reason) in clauses
+ collect `(is (,predicate ,expected ,actual) ,@reason))
+ (progn
+ (assert (evenp (list-length clauses)))
+ (loop for (expr value) on clauses by #'cddr
+ collect `(is (,predicate ,expr ,value)))))))
+
+(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 :test-expr ',condition)
+ (process-failure
+ :reason ,(if reason-args
+ `(format nil ,@reason-args)
+ `(format nil "~S did not return a true value" ',condition))
+ :test-expr ',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"
+
+ (with-unique-names (value)
+ `(let ((,value ,condition))
+ (if ,value
+ (process-failure
+ :reason ,(if reason-args
+ `(format nil ,@reason-args)
+ `(format nil "~S returned the value ~S, which is true" ',condition ,value ))
+ :test-expr ',condition)
+ (add-result 'test-passed :test-expr ',condition)))))
+
+(defmacro signals (condition-spec
+ &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)))
+ (destructuring-bind (condition &optional reason-control reason-args)
+ (ensure-list condition-spec)
+ `(block ,block-name
+ (handler-bind ((,condition (lambda (c)
+ (declare (ignore c))
+ ;; ok, body threw condition
+ (add-result 'test-passed
+ :test-expr ',condition)
+ (return-from ,block-name t))))
+ (block nil
+ ,@body))
+ (process-failure
+ :reason ,(if reason-control
+ `(format nil ,reason-control ,@reason-args)
+ `(format nil "Failed to signal a ~S" ',condition))
+ :test-expr ',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 :test-expr ',body)
+ (process-failure
+ :reason (format nil "Test didn't finish")
+ :test-expr ',body)))))
+
+(defmacro pass (&rest message-args)
+ "Simply generate a PASS."
+ `(add-result 'test-passed
+ :test-expr ',message-args
+ ,@(when message-args
+ `(:reason (format nil ,@message-args)))))
+
+(defmacro fail (&rest message-args)
+ "Simply generate a FAIL."
+ `(process-failure
+ :test-expr ',message-args
+ ,@(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
Added: trunk/thirdparty/fiveam/src/classes.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/src/classes.lisp Mon Feb 18 08:55:20 2008
@@ -0,0 +1,128 @@
+;; -*- 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 dependency
+ and was skipped. Or :depends-not-satisfied or :resolving")
+ (profiling-info :accessor profiling-info
+ :initform nil
+ :documentation "An object representing how
+ much time and memory where used by the
+ test.")
+ (collect-profiling-info :accessor collect-profiling-info
+ :initarg :collect-profiling-info
+ :initform nil
+ :documentation "When T profiling
+ information will be collected when the
+ test is run.")))
+
+(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 either test-cases or 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.")
+ (runtime-package :initarg :runtime-package :accessor runtime-package
+ :documentation "By default it stores *package* from the time this test was defined (macroexpanded)."))
+ (: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
Added: trunk/thirdparty/fiveam/src/explain.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/src/explain.lisp Mon Feb 18 08:55:20 2008
@@ -0,0 +1,131 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.FiveAM)
+
+;;;; * Analyzing the results
+
+(defparameter *verbose-failures* nil
+ "T if we should print the expression failing, NIL otherwise.")
+
+;;;; 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*) (recursive-depth 0))
+ #| "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))
+ (flet ((output (&rest format-args)
+ (format stream "~&~vT" recursive-depth)
+ (apply #'format stream format-args)))
+
+ (when (zerop num-checks)
+ (output "Didn't run anything...huh?")
+ (return-from explain nil))
+ (output "Did ~D check~P.~%" num-checks num-checks)
+ (output " Pass: ~D (~2D%)~%" num-passed passed%)
+ (output " Skip: ~D (~2D%)~%" num-skipped skipped%)
+ (output " Fail: ~D (~2D%)~%" num-failed failed%)
+ (when unknown
+ (output " UNKNOWN RESULTS: ~D (~2D)~%" num-unknown unknown%))
+ (terpri stream)
+ (when failed
+ (output "Failure Details:~%")
+ (dolist (f (reverse failed))
+ (output "--------------------------------~%")
+ (output "~A ~@{[~A]~}: ~%"
+ (name (test-case f))
+ (description (test-case f)))
+ (output " ~A.~%" (reason f))
+ (when (for-all-test-failed-p f)
+ (output "Results collected with failure data:~%")
+ (explain exp (slot-value f 'result-list)
+ stream (+ 4 recursive-depth)))
+ (when (and *verbose-failures* (test-expr f))
+ (output " ~S~%" (test-expr f)))
+ (output "--------------------------------~%"))
+ (terpri stream))
+ (when skipped
+ (output "Skip Details:~%")
+ (dolist (f skipped)
+ (output "~A ~@{[~A]~}: ~%"
+ (name (test-case f))
+ (description (test-case f)))
+ (output " ~A.~%" (reason f)))
+ (terpri *test-dribble*)))))
+
+(defmethod explain ((exp simple-text-explainer) results
+ &optional (stream *test-dribble*) (recursive-depth 0))
+ (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 "~&~vTRan ~D checks, ~D passed" recursive-depth 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 "~vT~D UNKNOWN RESULTS.~%" recursive-depth 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
Added: trunk/thirdparty/fiveam/src/fixture.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/src/fixture.lisp Mon Feb 18 08:55:20 2008
@@ -0,0 +1,71 @@
+;; -*- 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 focus 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"
+ (assert (get-fixture fixture-name)
+ (fixture-name)
+ "Unknown fixture ~S." fixture-name)
+ (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.
Added: trunk/thirdparty/fiveam/src/packages.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/src/packages.lisp Mon Feb 18 08:55:20 2008
@@ -0,0 +1,130 @@
+;; -*- lisp -*-
+
+;;;; * Introduction
+
+;;;; 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 :fiveam)
+ (:export ;; creating tests and test-suites
+ #:make-suite
+ #:def-suite
+ #:in-suite
+ #:in-suite*
+ #:make-test
+ #:test
+ #:get-test
+ #:rem-test
+ #:test-names
+ ;; fixtures
+ #:make-fixture
+ #:def-fixture
+ #:with-fixture
+ #:get-fixture
+ #:rem-fixture
+ ;; running checks
+ #:is
+ #:is-every
+ #:is-true
+ #:is-false
+ #:signals
+ #:finishes
+ #:skip
+ #:pass
+ #:fail
+ #:*test-dribble*
+ #:for-all
+ #:gen-integer
+ #:gen-float
+ #:gen-character
+ #:gen-string
+ #:gen-list
+ #:gen-tree
+ #:gen-buffer
+ #:gen-one-element
+ ;; running tests
+ #:run
+ #:run-all-tests
+ #:explain
+ #:explain!
+ #:run!
+ #:debug!
+ #:!
+ #:!!
+ #:!!!
+ #:*run-test-when-defined*
+ #:*debug-on-error*
+ #:*debug-on-failure*
+ #:*verbose-failures*
+ #:results-status))
+
+;;;; You can use #+5am to put your test-defining code inline with your
+;;;; other code - and not require people to have fiveam to run your
+;;;; package.
+
+(pushnew :5am *features*)
+
+;;;;@include "check.lisp"
+
+;;;;@include "random.lisp"
+
+;;;;@include "fixture.lisp"
+
+;;;;@include "test.lisp"
+
+;;;;@include "suite.lisp"
+
+;;;;@include "run.lisp"
+
+;;;;@include "explain.lisp"
+
+;;;; * Colophon
+
+;;;; This documentaion was written by Edward Marco Baringer
+;;;; <mb(a)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
Added: trunk/thirdparty/fiveam/src/random.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/src/random.lisp Mon Feb 18 08:55:20 2008
@@ -0,0 +1,265 @@
+;; -*- lisp -*-
+
+(in-package :it.bese.FiveAM)
+
+;;;; ** Random (QuickCheck-ish) testing
+
+;;;; FiveAM provides the ability to automatically generate a
+;;;; collection of random input data for a specific test and run a
+;;;; test multiple times.
+
+;;;; Specification testing is done through the FOR-ALL macro. This
+;;;; macro will bind variables to random data and run a test body a
+;;;; certain number of times. Should the test body ever signal a
+;;;; failure we stop running and report what values of the variables
+;;;; caused the code to fail.
+
+;;;; The generation of the random data is done using "generator
+;;;; functions" (see below for details). A generator function is a
+;;;; function which creates, based on user supplied parameters, a
+;;;; function which returns random data. In order to facilitate
+;;;; generating good random data the FOR-ALL macro also supports guard
+;;;; conditions and creating one random input based on the values of
+;;;; another (see the FOR-ALL macro for details).
+
+;;;; *** Public Interface to the Random Tester
+
+(defparameter *num-trials* 100
+ "Number of times we attempt to run the body of the FOR-ALL test.")
+
+(defparameter *max-trials* 10000
+ "Number of total times we attempt to run the body of the
+ FOR-ALL test including when the body is skipped due to failed
+ guard conditions.
+
+Since we have guard conditions we may get into infinite loops
+where the test code is never run due to the guards never
+returning true. This second run limit prevents that.")
+
+(defmacro for-all (bindings &body body)
+ "Bind BINDINGS to random variables and test BODY *num-trials* times.
+
+BINDINGS is a list of binding forms, each element is a list
+of (BINDING VALUE &optional GUARD). Value, which is evaluated
+once when the for-all is evaluated, must return a generator which
+be called each time BODY is evaluated. BINDING is either a symbol
+or a list which will be passed to destructuring-bind. GUARD is a
+form which, if present, stops BODY from executing when IT returns
+NIL. The GUARDS are evaluated after all the random data has been
+generated and they can refer to the current value of any
+binding. NB: Generator forms, unlike guard forms, can not contain
+references to the boud variables.
+
+Examples:
+
+ (for-all ((a (gen-integer)))
+ (is (integerp a)))
+
+ (for-all ((a (gen-integer) (plusp a)))
+ (is (integerp a))
+ (is (plusp a)))
+
+ (for-all ((less (gen-integer))
+ (more (gen-integer) (< less more)))
+ (is (<= less more)))
+
+ (for-all (((a b) (gen-two-integers)))
+ (is (integerp a))
+ (is (integerp b)))"
+ (with-unique-names (test-lambda-args)
+ `(perform-random-testing
+ (list ,@(mapcar #'second bindings))
+ (lambda (,test-lambda-args)
+ (destructuring-bind ,(mapcar #'first bindings)
+ ,test-lambda-args
+ (if (and ,@(delete-if #'null (mapcar #'third bindings)))
+ (progn ,@body)
+ (throw 'run-once
+ (list :guard-conditions-failed))))))))
+
+;;;; *** Implementation
+
+;;;; We could just make FOR-ALL a monster macro, but having FOR-ALL be
+;;;; a preproccessor for the perform-random-testing function is
+;;;; actually much easier.
+
+(defun perform-random-testing (generators body)
+ (loop
+ with random-state = *random-state*
+ with total-counter = *max-trials*
+ with counter = *num-trials*
+ with run-at-least-once = nil
+ until (or (zerop total-counter)
+ (zerop counter))
+ do (let ((result (perform-random-testing/run-once generators body)))
+ (ecase (first result)
+ (:pass
+ (decf counter)
+ (decf total-counter)
+ (setf run-at-least-once t))
+ (:no-tests
+ (add-result 'for-all-test-no-tests
+ :reason "No tests"
+ :random-state random-state)
+ (return-from perform-random-testing nil))
+ (:guard-conditions-failed
+ (decf total-counter))
+ (:fail
+ (add-result 'for-all-test-failed
+ :reason "Found failing test data"
+ :random-state random-state
+ :failure-values (second result)
+ :result-list (third result))
+ (return-from perform-random-testing nil))))
+ finally (if run-at-least-once
+ (add-result 'for-all-test-passed)
+ (add-result 'for-all-test-never-run
+ :reason "Guard conditions never passed"))))
+
+(defun perform-random-testing/run-once (generators body)
+ (catch 'run-once
+ (bind-run-state ((result-list '()))
+ (let ((values (mapcar #'funcall generators)))
+ (funcall body values)
+ (cond
+ ((null result-list)
+ (throw 'run-once (list :no-tests)))
+ ((every #'test-passed-p result-list)
+ (throw 'run-once (list :pass)))
+ ((notevery #'test-passed-p result-list)
+ (throw 'run-once (list :fail values result-list))))))))
+
+(defclass for-all-test-result ()
+ ((random-state :initarg :random-state)))
+
+(defclass for-all-test-passed (test-passed for-all-test-result)
+ ())
+
+(defclass for-all-test-failed (test-failure for-all-test-result)
+ ((failure-values :initarg :failure-values)
+ (result-list :initarg :result-list)))
+
+(defgeneric for-all-test-failed-p (object)
+ (:method ((object for-all-test-failed)) t)
+ (:method ((object t)) nil))
+
+(defmethod reason ((result for-all-test-failed))
+ (format nil "Falsafiable with ~S" (slot-value result 'failure-values)))
+
+(defclass for-all-test-no-tests (test-failure for-all-test-result)
+ ())
+
+(defclass for-all-test-never-run (test-failure for-all-test-result)
+ ())
+
+;;;; *** Generators
+
+;;;; Since this is random testing we need some way of creating random
+;;;; data to feed to our code. Generators are regular functions which
+;;;; create this random data.
+
+;;;; We provide a set of built-in generators.
+
+(defun gen-integer (&key (max (1+ most-positive-fixnum))
+ (min (1- most-negative-fixnum)))
+ "Returns a generator which produces random integers greater
+than or equal to MIN and less than or equal to MIN."
+ (lambda ()
+ (+ min (random (1+ (- max min))))))
+
+(defun gen-float (&key bound (type 'short-float))
+ "Returns a generator which producs floats of type TYPE. BOUND,
+if specified, constrains the ruselts to be in the range (-BOUND,
+BOUND)."
+ (lambda ()
+ (let* ((most-negative (ecase type
+ (short-float most-negative-short-float)
+ (single-float most-negative-single-float)
+ (double-float most-negative-double-float)
+ (long-float most-negative-long-float)))
+ (most-positive (ecase type
+ (short-float most-positive-short-float)
+ (single-float most-positive-single-float)
+ (double-float most-positive-double-float)
+ (long-float most-positive-long-float)))
+ (bound (or bound (max most-positive (- most-negative)))))
+ (coerce
+ (ecase (random 2)
+ (0 ;; generate a positive number
+ (random (min most-positive bound)))
+ (1 ;; generate a negative number
+ (- (random (min (- most-negative) bound)))))
+ type))))
+
+(defun gen-character (&key (code-limit char-code-limit)
+ (code (gen-integer :min 0 :max (1- code-limit)))
+ (alphanumericp nil))
+ "Returns a generator of characters.
+
+CODE must be a generator of random integers. ALPHANUMERICP, if
+non-NIL, limits the returned chars to those which pass
+alphanumericp."
+ (lambda ()
+ (if alphanumericp
+ (loop
+ for count upfrom 0
+ for char = (code-char (funcall code))
+ until (alphanumericp char)
+ when (= 1000 count)
+ do (error "After 1000 iterations ~S has still not generated an alphanumeric character :(."
+ code)
+ finally (return char))
+ (code-char (funcall code)))))
+
+(defun gen-string (&key (length (gen-integer :min 0 :max 80))
+ (elements (gen-character))
+ (element-type 'character))
+ "Returns a generator which producs random strings. LENGTH must
+be a generator which producs integers, ELEMENTS must be a
+generator which produces characters of type ELEMENT-TYPE."
+ (lambda ()
+ (loop
+ with length = (funcall length)
+ with string = (make-string length :element-type element-type)
+ for index below length
+ do (setf (aref string index) (funcall elements))
+ finally (return string))))
+
+(defun gen-list (&key (length (gen-integer :min 0 :max 10))
+ (elements (gen-integer :min -10 :max 10)))
+ "Returns a generator which producs random lists. LENGTH must be
+an integer generator and ELEMENTS must be a generator which
+producs objects."
+ (lambda ()
+ (loop
+ repeat (funcall length)
+ collect (funcall elements))))
+
+(defun gen-tree (&key (size 20)
+ (elements (gen-integer :min -10 :max 10)))
+ "Returns a generator which producs random trees. SIZE control
+the approximate size of the tree, but don't try anything above
+ 30, you have been warned. ELEMENTS must be a generator which
+will produce the elements."
+ (labels ((rec (&optional (current-depth 0))
+ (let ((key (random (+ 3 (- size current-depth)))))
+ (cond ((> key 2)
+ (list (rec (+ current-depth 1))
+ (rec (+ current-depth 1))))
+ (t (funcall elements))))))
+ (lambda ()
+ (rec))))
+
+(defun gen-buffer (&key (length (gen-integer :min 0 :max 50))
+ (element-type '(unsigned-byte 8))
+ (elements (gen-integer :min 0 :max (1- (expt 2 8)))))
+ (lambda ()
+ (let ((buffer (make-array (funcall length) :element-type element-type)))
+ (map-into buffer elements))))
+
+(defun gen-one-element (&rest elements)
+ (lambda ()
+ (nth (random (length elements)) elements)))
+
+;;;; The trivial always-produce-the-same-thing generator is done using
+;;;; cl:constantly.
Added: trunk/thirdparty/fiveam/src/run.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/src/run.lisp Mon Feb 18 08:55:20 2008
@@ -0,0 +1,288 @@
+;; -*- 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* nil
+ "T if we should drop into a debugger on error, NIL otherwise.")
+
+(defparameter *debug-on-failure* nil
+ "T if we should drop into a debugger on a failing check, 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))
+ (eql t (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))
+ (:before (every #'(lambda (dep)
+ (let ((status (status (get-test dep))))
+ (eql :unknown status)))
+ (cdr depends-on)))))))
+
+(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)
+ (bind-run-state ((current-test test))
+ (labels ((abort-test (e)
+ (add-result 'unexpected-test-failure
+ :test-expr nil
+ :test-case test
+ :reason (format nil "Unexpected Error: ~S~%~A." e e)
+ :condition e))
+ (run-it ()
+ (let ((result-list '()))
+ (declare (special result-list))
+ (handler-bind ((check-failure (lambda (e)
+ (declare (ignore e))
+ (unless *debug-on-failure*
+ (invoke-restart
+ (find-restart 'ignore-failure)))))
+ (error (lambda (e)
+ (unless (or *debug-on-error*
+ (typep e 'check-failure))
+ (abort-test e)
+ (return-from run-it result-list)))))
+ (restart-case
+ (let ((*readtable* (copy-readtable))
+ (*package* (runtime-package test)))
+ (if (collect-profiling-info test)
+ (setf (profiling-info test)
+ (arnesi:collect-timing (test-lambda test)))
+ (funcall (test-lambda test))))
+ (retest ()
+ :report (lambda (stream)
+ (format stream "~@<Rerun the test ~S~@:>" test))
+ (return-from run-it (run-it)))
+ (ignore ()
+ :report (lambda (stream)
+ (format stream "~@<Signal an exceptional test failure and abort the test ~S.~@:>" test))
+ (abort-test (make-instance 'test-failure :test-case test
+ :reason "Failure restart."))))
+ result-list))))
+ (let ((results (run-it)))
+ (setf (status test) (results-status results)
+ result-list (nconc result-list results)))))))
+
+(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 ((tests list))
+ (mapc #'%run tests))
+
+(defmethod %run ((suite test-suite))
+ (let ((suite-results '()))
+ (flet ((run-tests ()
+ (loop
+ for test being the hash-values of (tests suite)
+ do (%run test))))
+ (unwind-protect
+ (bind-run-state ((result-list '()))
+ (unwind-protect
+ (if (collect-profiling-info suite)
+ (setf (profiling-info suite) (collect-timing #'run-tests))
+ (run-tests)))
+ (setf suite-results result-list
+ (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! (&optional (test-spec *suite*))
+ "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 debug! (&optional (test-spec *suite*))
+ "Calls (run! test-spec) but enters the debugger if any kind of error happens."
+ (let ((*debug-on-error* t)
+ (*debug-on-failure* t))
+ (run! test-spec)))
+
+(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 '()))
+ (with-simple-restart (explain "Ignore the rest of the tests and explain current results")
+ (%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.
Added: trunk/thirdparty/fiveam/src/style.css
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/src/style.css Mon Feb 18 08:55:20 2008
@@ -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; }
Added: trunk/thirdparty/fiveam/src/suite.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/src/suite.lisp Mon Feb 18 08:55:20 2008
@@ -0,0 +1,115 @@
+;; -*- 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 the way test are run nor the 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. NB: This macro is built on top of make-suite,
+as such it, like make-suite, will overrwrite any existing suite
+named NAME."
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (make-suite ',name
+ ,@(when description `(:description ,description))
+ ,@(when in `(:in ',in)))
+ ',name))
+
+(defmacro def-suite* (name &rest def-suite-args)
+ `(progn
+ (def-suite ,name ,@def-suite-args)
+ (in-suite ,name)))
+
+(defun make-suite (name &key description in)
+ "Create a new test suite object.
+
+Overides any existing suite named NAME."
+ (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*"
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (%in-suite ,suite-name)))
+
+(defmacro in-suite* (suite-name &key in)
+ "Just like in-suite, but silently creates missing suites."
+ `(%in-suite ,suite-name :in ,in :fail-on-error nil))
+
+(defmacro %in-suite (suite-name &key (fail-on-error t) in)
+ (with-unique-names (suite)
+ `(progn
+ (if-bind ,suite (get-test ',suite-name)
+ (setf *suite* ,suite)
+ (progn
+ (when ,fail-on-error
+ (cerror "Create a new suite named ~A."
+ "Unkown suite ~A." ',suite-name))
+ (setf (get-test ',suite-name) (make-suite ',suite-name :in ',in)
+ *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
Added: trunk/thirdparty/fiveam/src/test.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/src/test.lisp Mon Feb 18 08:55:20 2008
@@ -0,0 +1,122 @@
+;; -*- 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
+ :at-redefinition nil
+ :documentation "Lookup table mapping test (and test suite)
+ names to objects.")
+
+(defun test-names ()
+ (loop for test being the hash-keys of *test*
+ collect test))
+
+(defmacro test (name &body body)
+ "Create a test named NAME. If NAME is a list it must be of the
+form:
+
+ (name &key depends-on suite fixture compile-at profile)
+
+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.
+
+FIXTURE specifies a fixtrue to wrap the body in.
+
+If PROFILE is T profiling information will be collected as well."
+ (let* ((tmp (gensym))
+ (suite-arg (getf (cdr (ensure-list name)) :suite tmp))
+ (suite-form (cond
+ ((eq tmp suite-arg) '*suite*)
+ (t `(get-test ',suite-arg)))))
+ (when (consp name)
+ (remf (cdr name) :suite))
+ (destructuring-bind (name &key depends-on (compile-at :run-time) fixture profile)
+ (ensure-list name)
+ (declare (type (member :run-time :definition-time) compile-at))
+ (let ((description (if (stringp (car body))
+ (pop body)
+ ""))
+ (effective-body (if fixture
+ (destructuring-bind (name &rest args)
+ (ensure-list fixture)
+ `((with-fixture ,name ,args ,@body)))
+ body)))
+ `(progn
+ (setf (get-test ',name) (make-instance 'test-case
+ :name ',name
+ :runtime-package
+ #-ecl ,*package*
+ #+ecl (find-package ,(package-name *package*))
+ :test-lambda
+ (lambda ()
+ ,@ (ecase compile-at
+ (:run-time `((funcall
+ (let ((*package* (find-package ',(package-name *package*))))
+ (compile nil '(lambda ()
+ ,@effective-body))))))
+ (:definition-time effective-body)))
+ :description ,description
+ :depends-on ',depends-on
+ :collect-profiling-info ,profile))
+ (setf (gethash ',name (tests ,suite-form)) ',name)
+ (when *run-test-when-defined*
+ (run! ',name))
+ ',name)))))
+
+(defvar *run-test-when-defined* nil
+ "When non-NIL tests are run as soon as they are defined.")
+
+;; 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.
Added: trunk/thirdparty/fiveam/t/example.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/t/example.lisp Mon Feb 18 08:55:20 2008
@@ -0,0 +1,126 @@
+;; -*- lisp -*-
+
+;;;; * FiveAM Example (poor man's tutorial)
+
+(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! (run 'add-2))
+
+;;;; 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))))
+
+;;;; Finally let's try out the specification based testing.
+
+(defun dummy-add (a b)
+ (+ a b))
+
+(defun dummy-strcat (a b)
+ (concatenate 'string a b))
+
+(test dummy-add
+ (for-all ((a (gen-integer))
+ (b (gen-integer)))
+ ;; assuming we have an "oracle" to compare our function results to
+ ;; we can use it:
+ (is (= (+ a b) (dummy-add a b)))
+ ;; if we don't have an oracle (as in most cases) we just ensure
+ ;; that certain properties hold:
+ (is (= (dummy-add a b)
+ (dummy-add b a)))
+ (is (= a (dummy-add a 0)))
+ (is (= 0 (dummy-add a (- a))))
+ (is (< a (dummy-add a 1)))
+ (is (= (* 2 a) (dummy-add a a)))))
+
+(test dummy-strcat
+ (for-all ((result (gen-string))
+ (split-point (gen-integer :min 0 :max 10000)
+ (< split-point (length result))))
+ (is (string= result (dummy-strcat (subseq result 0 split-point)
+ (subseq result split-point))))))
+
+(test random-failure
+ (for-all ((result (gen-integer :min 0 :max 1)))
+ (is (plusp result))
+ (is (= result 0))))
+
+(run! 'example-suite)
Added: trunk/thirdparty/fiveam/t/suite.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/t/suite.lisp Mon Feb 18 08:55:20 2008
@@ -0,0 +1,9 @@
+;;;; -*- lisp -*-
+
+(in-package :it.bese.fiveam)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (unless (get-test :it.bese)
+ (def-suite :it.bese)))
+
+(def-suite :it.bese.fiveam :in :it.bese)
Added: trunk/thirdparty/fiveam/t/tests.lisp
==============================================================================
--- (empty file)
+++ trunk/thirdparty/fiveam/t/tests.lisp Mon Feb 18 08:55:20 2008
@@ -0,0 +1,256 @@
+;;;; -*- 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))
+
+(def-fixture null-fixture ()
+ `(progn ,@(&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 :fixture null-fixture)
+ (is (plusp 0))
+ (is (< 0 -1))
+ (is (not (plusp 1)))
+ (is (not (< 0 1)))
+ (is-true nil)
+ (is-false t))
+
+(test (is :profile t)
+ (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)))
+
+
+(def-suite before-test-suite :description "Suite for before test")
+
+(test (before-0 :suite before-test-suite)
+ (pass))
+
+(test (before-1 :depends-on (:before before-0)
+ :suite before-test-suite)
+ (fail))
+
+(def-suite before-test-suite-2 :description "Suite for before test")
+
+(test (before-2 :depends-on (:before before-3)
+ :suite before-test-suite-2)
+ (pass))
+
+(test (before-3 :suite before-test-suite-2)
+ (pass))
+
+(test before
+ (with-test-results (results before-test-suite)
+ (is (some #'test-skipped-p results)))
+
+ (with-test-results (results before-test-suite-2)
+ (is (every #'test-passed-p results))))
+
+
+;;;; dependencies with symbol
+(test (dep-with-symbol-first :suite test-suite)
+ (pass))
+
+(test (dep-with-symbol-dependencies-not-met :depends-on (not dep-with-symbol-first)
+ :suite test-suite)
+ (fail "Error in the test of the test, this should not ever happen"))
+
+(test (dep-with-symbol-depends-on-ok :depends-on dep-with-symbol-first :suite test-suite)
+ (pass))
+
+(test (dep-with-symbol-depends-on-failed-dependency :depends-on dep-with-symbol-dependencies-not-met
+ :suite test-suite)
+ (fail "No, I should not be tested becuase I depend on a test that in its turn has a failed dependecy."))
+
+(test dependencies-with-symbol
+ (with-test-results (results dep-with-symbol-first)
+ (is (some #'test-passed-p results)))
+
+ (with-test-results (results dep-with-symbol-depends-on-ok)
+ (is (some #'test-passed-p results)))
+
+ (with-test-results (results dep-with-symbol-dependencies-not-met)
+ (is (some #'test-skipped-p results)))
+
+ ;; No failure here, because it means the test was run.
+ (with-test-results (results dep-with-symbol-depends-on-failed-dependency)
+ (is (not (some #'test-failure-p results)))))
+
+
+;;;; test for-all
+
+(test gen-integer
+ (for-all ((a (gen-integer)))
+ (is (integerp a))))
+
+(test for-all-guarded
+ (for-all ((less (gen-integer))
+ (more (gen-integer) (< less more)))
+ (is (< less more))))
+
+(test gen-float
+ (macrolet ((test-gen-float (type)
+ `(for-all ((unbounded (gen-float :type ',type))
+ (bounded (gen-float :type ',type :bound 42)))
+ (is (typep unbounded ',type))
+ (is (typep bounded ',type))
+ (is (<= (abs bounded) 42)))))
+ (test-gen-float single-float)
+ (test-gen-float short-float)
+ (test-gen-float double-float)
+ (test-gen-float long-float)))
+
+(test gen-character
+ (for-all ((c (gen-character)))
+ (is (characterp c)))
+ (for-all ((c (gen-character :code (gen-integer :min 32 :max 40))))
+ (is (characterp c))
+ (member c (list #\Space #\! #\" #\# #\$ #\% #\& #\' #\())))
+
+(test gen-string
+ (for-all ((s (gen-string)))
+ (is (stringp s)))
+ (for-all ((s (gen-string :length (gen-integer :min 0 :max 2))))
+ (is (<= (length s) 2)))
+ (for-all ((s (gen-string :elements (gen-character :code (gen-integer :min 0 :max 0))
+ :length (constantly 2))))
+ (is (= 2 (length s)))
+ (is (every (curry #'char= #\Null) s))))
+
+(defun dummy-mv-generator ()
+ (lambda ()
+ (list 1 1)))
+
+(test for-all-destructuring-bind
+ (for-all (((a b) (dummy-mv-generator)))
+ (is (= 1 a))
+ (is (= 1 b))))
