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@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@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@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))))