From 728a186263688293c214297cf8ea34dde8b20edb Mon Sep 17 00:00:00 2001 From: Vincent Ambo Date: Fri, 17 Jan 2020 18:37:23 +0000 Subject: [PATCH] Squashed 'third_party/lisp/fiveam/' content from commit ee9456a2 git-subtree-dir: third_party/lisp/fiveam git-subtree-split: ee9456a2ac52b1c9f5f5f789d263f0f76a15176c --- .boring | 14 ++ .travis.yml | 47 ++++++ COPYING | 30 ++++ README | 8 + docs/make-qbook.lisp | 13 ++ fiveam.asd | 36 ++++ src/check.lisp | 311 ++++++++++++++++++++++++++++++++++ src/classes.lisp | 128 ++++++++++++++ src/explain.lisp | 133 +++++++++++++++ src/fixture.lisp | 82 +++++++++ src/package.lisp | 139 ++++++++++++++++ src/random.lisp | 265 +++++++++++++++++++++++++++++ src/run.lisp | 385 +++++++++++++++++++++++++++++++++++++++++++ src/style.css | 64 +++++++ src/suite.lisp | 140 ++++++++++++++++ src/test.lisp | 167 +++++++++++++++++++ src/utils.lisp | 226 +++++++++++++++++++++++++ t/example.lisp | 126 ++++++++++++++ t/tests.lisp | 280 +++++++++++++++++++++++++++++++ version.sexp | 2 + 20 files changed, 2596 insertions(+) create mode 100644 .boring create mode 100644 .travis.yml create mode 100644 COPYING create mode 100644 README create mode 100644 docs/make-qbook.lisp create mode 100644 fiveam.asd create mode 100644 src/check.lisp create mode 100644 src/classes.lisp create mode 100644 src/explain.lisp create mode 100644 src/fixture.lisp create mode 100644 src/package.lisp create mode 100644 src/random.lisp create mode 100644 src/run.lisp create mode 100644 src/style.css create mode 100644 src/suite.lisp create mode 100644 src/test.lisp create mode 100644 src/utils.lisp create mode 100644 t/example.lisp create mode 100644 t/tests.lisp create mode 100644 version.sexp diff --git a/.boring b/.boring new file mode 100644 index 000000000..662944f76 --- /dev/null +++ b/.boring @@ -0,0 +1,14 @@ +# Boring file regexps: +\# +~$ +(^|/)_darcs($|/) +\.dfsl$ +\.ppcf$ +\.fasl$ +\.x86f$ +\.fas$ +\.lib$ +^docs/html($|/) +^docs/pdf($|/) +^\{arch\}$ +(^|/).arch-ids($|/) diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 000000000..6f6559189 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,47 @@ +dist: bionic +language: lisp + +env: + matrix: + - LISP=abcl + - LISP=allegro + - LISP=ccl + - LISP=ccl32 + - LISP=ecl + - LISP=sbcl + - LISP=sbcl32 + - LISP=cmucl + +matrix: + allow_failures: + - env: LISP=allegro + - env: LISP=ccl32 + - env: LISP=cmucl + - env: LISP=sbcl32 + +notifications: + email: + on_success: change + on_failure: always + irc: + channels: + - "chat.freenode.net#iolib" + on_success: change + on_failure: always + use_notice: true + skip_join: true + +install: + - curl -L https://raw.githubusercontent.com/sionescu/cl-travis/master/install.sh | sh + - cl -e "(cl:in-package :cl-user) + (dolist (p '(:alexandria)) + (ql:quickload p :verbose t))" + +script: + - cl -e "(cl:in-package :cl-user) + (ql:quickload :fiveam/test :verbose t) + (uiop:quit (if (some (lambda (x) (typep x '5am::test-failure)) + (5am:run :it.bese.fiveam)) + 1 0))" + +sudo: required diff --git a/COPYING b/COPYING new file mode 100644 index 000000000..91adf85a5 --- /dev/null +++ b/COPYING @@ -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. + diff --git a/README b/README new file mode 100644 index 000000000..32a205fa5 --- /dev/null +++ b/README @@ -0,0 +1,8 @@ +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 fiveam-devel@common-lisp.net + +All the code is Copyright (C) 2002-2006 Edward Marco Baringer. diff --git a/docs/make-qbook.lisp b/docs/make-qbook.lisp new file mode 100644 index 000000000..8144c94f0 --- /dev/null +++ b/docs/make-qbook.lisp @@ -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))))) + + + diff --git a/fiveam.asd b/fiveam.asd new file mode 100644 index 000000000..7607e3337 --- /dev/null +++ b/fiveam.asd @@ -0,0 +1,36 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +#.(unless (or #+asdf3.1 (version<= "3.1" (asdf-version))) + (error "You need ASDF >= 3.1 to load this system correctly.")) + +(defsystem :fiveam + :author "Edward Marco Baringer " + :version (:read-file-form "version.sexp") + :description "A simple regression testing framework" + :license "BSD" + :depends-on (:alexandria :net.didierverna.asdf-flv :trivial-backtrace) + :pathname "src/" + :components ((:file "package") + (:file "utils" :depends-on ("package")) + (:file "check" :depends-on ("package" "utils")) + (:file "fixture" :depends-on ("package")) + (:file "classes" :depends-on ("package")) + (:file "random" :depends-on ("package" "check")) + (:file "test" :depends-on ("package" "fixture" "classes")) + (:file "explain" :depends-on ("package" "utils" "check" "classes" "random")) + (:file "suite" :depends-on ("package" "test" "classes")) + (:file "run" :depends-on ("package" "check" "classes" "test" "explain" "suite"))) + :in-order-to ((test-op (test-op :fiveam/test)))) + +(defsystem :fiveam/test + :author "Edward Marco Baringer " + :description "FiveAM's own test suite" + :license "BSD" + :depends-on (:fiveam) + :pathname "t/" + :components ((:file "tests")) + :perform (test-op (o c) (symbol-call :5am :run! :it.bese.fiveam))) + +;;;;@include "src/package.lisp" + +;;;;@include "t/example.lisp" diff --git a/src/check.lisp b/src/check.lisp new file mode 100644 index 000000000..b3808c5cf --- /dev/null +++ b/src/check.lisp @@ -0,0 +1,311 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +(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))))) + +(defun process-failure (test-expr &optional reason-format &rest format-args) + (let ((reason (and reason-format + (apply #'format nil reason-format format-args)))) + (with-simple-restart (ignore-failure "Continue the test run.") + (error 'check-failure :test-expr test-expr + :reason reason)) + (add-result 'test-failure :test-expr test-expr + :reason reason))) + +(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 the test when +appropriate.")) + +(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 add 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 produces 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-gensyms (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.") + (rotatef expected actual)) + (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 "~2&~S~2% evaluated to ~2&~S~2% which is ~2&~S~2%to ~2&~S~2% (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 "~2&~S~2% evaluated to ~2&~S~2% which satisfies ~2&~S~2% (it should not)" + `',?value v `',?satisfies))) + ((?predicate ?expected ?actual) + (process-entry ?predicate ?expected ?actual) + (setf default-reason-args + (list "~2&~S~2% evaluated to ~2&~S~2% which is not ~2&~S~2% to ~2&~S~2%." + `',?actual a `',?predicate e))) + ((?satisfies ?value) + (setf bindings (list (list v ?value)) + effective-test `(,?satisfies ,v) + default-reason-args + (list "~2&~S~2% evaluated to ~2&~S~2% which does not satisfy ~2&~S~2%" + `',?value v `',?satisfies))) + (?_ + (setf bindings '() + effective-test test + default-reason-args (list "~2&~S~2% was NIL." `',test))))) + `(let ,bindings + (if ,effective-test + (add-result 'test-passed :test-expr ',test) + (process-failure ',test + ,@(or reason-args default-reason-args))))))) + +;;;; *** Other checks + +(defmacro skip (&rest reason) + "Generates a TEST-SKIPPED result." + `(progn + (format *test-dribble* "s") + (add-result 'test-skipped :reason (format nil ,@reason)))) + +(defmacro is-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 ',condition + ,@(or reason-args + `("~S did not return a true value" ',condition))))) + +(defmacro is-false (condition &rest reason-args) + "Generates a pass if CONDITION returns false, generates a + failure otherwise. Like IS-TRUE, and unlike IS, IS-FALSE does + not inspect CONDITION to determine what reason to give it case + of test failure" + (with-gensyms (value) + `(let ((,value ,condition)) + (if ,value + (process-failure ',condition + ,@(or reason-args + `("~S returned the value ~S, which is true" ',condition ,value))) + (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 + ',condition + ,@(if reason-control + `(,reason-control ,@reason-args) + `("Failed to signal a ~S" ',condition))) + (return-from ,block-name nil))))) + +(defmacro finishes (&body body) + "Generates a pass if BODY executes to normal completion. In +other words if body does signal, return-from or throw this test +fails." + `(unwind-protect-case () (progn ,@body) + (:normal (add-result 'test-passed :test-expr ',body)) + (:abort (process-failure ',body "Test didn't finish")))) + +(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 ',message-args + ,@message-args)) + +;; Copyright (c) 2002-2003, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE diff --git a/src/classes.lisp b/src/classes.lisp new file mode 100644 index 000000000..fc4dc782e --- /dev/null +++ b/src/classes.lisp @@ -0,0 +1,128 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +(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 diff --git a/src/explain.lisp b/src/explain.lisp new file mode 100644 index 000000000..015cdf455 --- /dev/null +++ b/src/explain.lisp @@ -0,0 +1,133 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +(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. + +(defgeneric explain (explainer results &optional stream recursive-depth) + (:documentation "Given a list of test results report write to stream detailed + human readable statistics regarding the results.")) + +(defmethod explain ((exp detailed-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)) + (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 stream))))) + +(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 diff --git a/src/fixture.lisp b/src/fixture.lisp new file mode 100644 index 000000000..26e993304 --- /dev/null +++ b/src/fixture.lisp @@ -0,0 +1,82 @@ +;; -*- 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. + +(defvar *fixture* + (make-hash-table :test 'eql) + "Lookup table mapping fixture names to fixture + objects.") + +(defun get-fixture (key &optional default) + (gethash key *fixture* default)) + +(defun (setf get-fixture) (value key) + (setf (gethash key *fixture*) value)) + +(defun rem-fixture (key) + (remhash key *fixture*)) + +(defmacro def-fixture (name (&rest 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 (&rest 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 ((&rest largs) &rest lbody) + (get-fixture fixture-name) + `(macrolet ((&body () '(progn ,@body))) + (funcall (lambda (,@largs) ,@lbody) ,@args)))) + +;; Copyright (c) 2002-2003, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/src/package.lisp b/src/package.lisp new file mode 100644 index 000000000..3279a9a4f --- /dev/null +++ b/src/package.lisp @@ -0,0 +1,139 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +;;;; * 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 :alexandria) + (:nicknames :5am :fiveam) + #+sb-package-locks + (:lock t) + (:export + ;; creating tests and test-suites + #:make-suite + #:def-suite + #:def-suite* + #:in-suite + #:in-suite* + #:test + #:def-test + #:get-test + #:rem-test + #:test-names + #:*default-test-compilation-time* + ;; fixtures + #: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 + #:*num-trials* + #:*max-trials* + #: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* + #:*on-error* + #:*on-failure* + #:*verbose-failures* + #:*print-names* + #: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 +;;;; and generated by qbook. + +;;;; ** COPYRIGHT + +;;;; Copyright (c) 2002-2003, Edward Marco Baringer +;;;; All rights reserved. + +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions are +;;;; met: + +;;;; - Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. + +;;;; - Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. + +;;;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;;;; of its contributors may be used to endorse or promote products +;;;; derived from this software without specific prior written permission. + +;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE diff --git a/src/random.lisp b/src/random.lisp new file mode 100644 index 000000000..49e14bc8a --- /dev/null +++ b/src/random.lisp @@ -0,0 +1,265 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +(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 bound 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-gensyms (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 "Falsifiable 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 MAX." + (lambda () + (+ min (random (1+ (- max min)))))) + +(defun gen-float (&key bound (type 'short-float)) + "Returns a generator which produces floats of type TYPE. BOUND, +if specified, constrains the results 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 () + (loop + for count upfrom 0 + for char = (code-char (funcall code)) + until (and char + (or (not alphanumericp) + (alphanumericp char))) + when (= 1000 count) + do (error "After 1000 iterations ~S has still not generated ~:[a valid~;an alphanumeric~] character :(." + code alphanumericp) + finally (return char)))) + +(defun gen-string (&key (length (gen-integer :min 0 :max 80)) + (elements (gen-character)) + (element-type 'character)) + "Returns a generator which produces random strings. LENGTH must +be a generator which produces 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 produces random lists. LENGTH must be +an integer generator and ELEMENTS must be a generator which +produces 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 produces random trees. SIZE controls +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. diff --git a/src/run.lisp b/src/run.lisp new file mode 100644 index 000000000..89c522351 --- /dev/null +++ b/src/run.lisp @@ -0,0 +1,385 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +(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 *on-error* is :DEBUG 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. + +(deftype on-problem-action () + '(member :debug :backtrace nil)) + +(declaim (type on-problem-action *on-error* *on-failure*)) + +(defvar *on-error* nil + "The action to perform on error: +- :DEBUG if we should drop into the debugger +- :BACKTRACE to print a backtrace +- NIL to simply continue") + +(defvar *on-failure* nil + "The action to perform on check failure: +- :DEBUG if we should drop into the debugger +- :BACKTRACE to print a backtrace +- NIL to simply continue") + +(defvar *debug-on-error* nil + "T if we should drop into the debugger on error, NIL otherwise. +OBSOLETE: superseded by *ON-ERROR*") + +(defvar *debug-on-failure* nil + "T if we should drop into the debugger on a failing check, NIL otherwise. +OBSOLETE: superseded by *ON-FAILURE*") + +(defparameter *print-names* t + "T if we should print test running progress, NIL otherwise.") + +(defparameter *test-dribble-indent* (make-array 0 + :element-type 'character + :fill-pointer 0 + :adjustable t) + "Used to indent tests and test suites in their parent suite") + +(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 also +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)))) + +(defgeneric resolve-dependencies (depends-on)) + +(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)))) + (if (eql :unknown status) + (run-resolving-dependencies (get-test dep)) + status))) + (cdr depends-on))))))) + +(defun results-status (result-list) + "Given a list of test results (generated while running a test) + return true if no results are of type TEST-FAILURE. Returns second + and third values, which are the set of failed tests and skipped + tests respectively." + (let ((failed-tests + (remove-if-not #'test-failure-p result-list)) + (skipped-tests + (remove-if-not #'test-skipped-p result-list))) + (values (null failed-tests) + failed-tests + skipped-tests))) + +(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)) + +(defgeneric run-test-lambda (test)) + +(defmethod run-test-lambda ((test test-case)) + (with-run-state (result-list) + (bind-run-state ((current-test test)) + (labels ((abort-test (e &optional (reason (format nil "Unexpected Error: ~S~%~A." e e))) + (add-result 'unexpected-test-failure + :test-expr nil + :test-case test + :reason reason + :condition e)) + (run-it () + (let ((result-list '())) + (declare (special result-list)) + (handler-bind ((check-failure (lambda (e) + (declare (ignore e)) + (cond + ((eql *on-failure* :debug) + nil) + (t + (when (eql *on-failure* :backtrace) + (trivial-backtrace:print-backtrace-to-stream + *test-dribble*)) + (invoke-restart + (find-restart 'ignore-failure)))))) + (error (lambda (e) + (unless (or (eql *on-error* :debug) + (typep e 'check-failure)) + (when (eql *on-error* :backtrace) + (trivial-backtrace:print-backtrace-to-stream + *test-dribble*)) + (abort-test e) + (return-from run-it result-list))))) + (restart-case + (handler-case + (let ((*readtable* (copy-readtable)) + (*package* (runtime-package test))) + (when *print-names* + (format *test-dribble* "~%~ARunning test ~A " *test-dribble-indent* (name test))) + (if (collect-profiling-info test) + ;; Timing info doesn't get collected ATM, we need a portable library + ;; (setf (profiling-info test) (collect-timing (test-lambda test))) + (funcall (test-lambda test)) + (funcall (test-lambda test)))) + (storage-condition (e) + ;; heap-exhausted/constrol-stack-exhausted + ;; handler-case unwinds the stack (unlike handler-bind) + (abort-test e (format nil "STORAGE-CONDITION: aborted for safety. ~S~%~A." e e)) + (return-from run-it result-list))) + (retest () + :report (lambda (stream) + (format stream "~@" test)) + (return-from run-it (run-it))) + (ignore () + :report (lambda (stream) + (format stream "~@" 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 variables !, + !!, !!!")) + +(defmethod %run ((test test-case)) + (run-resolving-dependencies test)) + +(defmethod %run ((tests list)) + (mapc #'%run tests)) + +(defmethod %run ((suite test-suite)) + (when *print-names* + (format *test-dribble* "~%~ARunning test suite ~A" *test-dribble-indent* (name suite))) + (let ((suite-results '())) + (flet ((run-tests () + (loop + for test being the hash-values of (tests suite) + do (%run test)))) + (vector-push-extend #\space *test-dribble-indent*) + (unwind-protect + (bind-run-state ((result-list '())) + (unwind-protect + (if (collect-profiling-info suite) + ;; Timing info doesn't get collected ATM, we need a portable library + ;; (setf (profiling-info suite) (collect-timing #'run-tests)) + (run-tests) + (run-tests))) + (setf suite-results result-list + (status suite) (every #'test-passed-p suite-results))) + (vector-pop *test-dribble-indent*) + (with-run-state (result-list) + (setf result-list (nconc result-list suite-results))))))) + +(defmethod %run ((test-name symbol)) + (when-let (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*) + &key ((:print-names *print-names*) *print-names*)) + "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*. +Return a boolean indicating whether no tests failed." + (explain (make-instance 'detailed-text-explainer) result-list *test-dribble*) + (results-status result-list)) + +(defun debug! (&optional (test-spec *suite*)) + "Calls (run! test-spec) but enters the debugger if any kind of error happens." + (let ((*on-error* :debug) + (*on-failure* :debug)) + (run! test-spec))) + +(defun run (test-spec &key ((:print-names *print-names*) *print-names*)) + "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)) + *!!* *!* + *!!!* *!!*) + (let ((*on-error* + (or *on-error* (cond + (*debug-on-error* + (format *test-dribble* "*DEBUG-ON-ERROR* is obsolete. Use *ON-ERROR*.") + :debug) + (t nil)))) + (*on-failure* + (or *on-failure* (cond + (*debug-on-failure* + (format *test-dribble* "*DEBUG-ON-FAILURE* is obsolete. Use *ON-FAILURE*.") + :debug) + (t nil))))) + (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 *!!!*))) + +(defun run-all-tests (&key (summary :end)) + "Runs all defined test suites, T if all tests passed and NIL otherwise. +SUMMARY can be :END to print a summary at the end, :SUITE to print it +after each suite or NIL to skip explanations." + (check-type summary (member nil :suite :end)) + (loop :for suite :in (cons 'nil (sort (copy-list *toplevel-suites*) #'string<=)) + :for results := (if (suite-emptyp suite) nil (run suite)) + :when (consp results) + :collect results :into all-results + :do (cond + ((not (eql summary :suite)) + nil) + (results + (explain! results)) + (suite + (format *test-dribble* "Suite ~A is empty~%" suite))) + :finally (progn + (when (eql summary :end) + (explain! (alexandria:flatten all-results))) + (return (every #'results-status all-results))))) + +;; Copyright (c) 2002-2003, Edward Marco Baringer +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in the +;; documentation and/or other materials provided with the distribution. +;; +;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names +;; of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/src/style.css b/src/style.css new file mode 100644 index 000000000..4a1e6010d --- /dev/null +++ b/src/style.css @@ -0,0 +1,64 @@ +body { + background-color: #FFFFFF; + color: #000000; + padding: 0px; margin: 0px; +} + +.qbook { width: 600px; background-color: #FFFFFF; margin: 0px; + border-left: 3em solid #660000; padding: 3px; } + +h1 { text-align: center; margin: 0px; + color: #333333; + border-bottom: 0.3em solid #660000; +} + +p { padding-left: 1em; } + +h2 { border-bottom: 0.2em solid #000000; font-family: verdana; } + +h3 { border-bottom: 0.1em solid #000000; } + +pre.code { + background-color: #eeeeee; + border: solid 1px #d0d0d0; + overflow: auto; +} + +pre.code * .paren { color: #666666; } + +pre.code a:active { color: #000000; } +pre.code a:link { color: #000000; } +pre.code a:visited { color: #000000; } + +pre.code .first-line { font-weight: bold; } + +div.contents { font-family: verdana; } + +div.contents a:active { color: #000000; } +div.contents a:link { color: #000000; } +div.contents a:visited { color: #000000; } + +div.contents div.contents-heading-1 { padding-left: 0.5em; font-weight: bold; } +div.contents div.contents-heading-1 a:active { color: #660000; } +div.contents div.contents-heading-1 a:link { color: #660000; } +div.contents div.contents-heading-1 a:visited { color: #660000; } + +div.contents div.contents-heading-2 { padding-left: 1.0em; } +div.contents div.contents-heading-2 a:active { color: #660000; } +div.contents div.contents-heading-2 a:link { color: #660000; } +div.contents div.contents-heading-2 a:visited { color: #660000; } + +div.contents div.contents-heading-3 { padding-left: 1.5em; } +div.contents div.contents-heading-3 a:active { color: #660000; } +div.contents div.contents-heading-3 a:link { color: #660000; } +div.contents div.contents-heading-3 a:visited { color: #660000; } + +div.contents div.contents-heading-4 { padding-left: 2em; } +div.contents div.contents-heading-4 a:active { color: #660000; } +div.contents div.contents-heading-4 a:link { color: #660000; } +div.contents div.contents-heading-4 a:visited { color: #660000; } + +div.contents div.contents-heading-5 { padding-left: 2.5em; } +div.contents div.contents-heading-5 a:active { color: #660000; } +div.contents div.contents-heading-5 a:link { color: #660000; } +div.contents div.contents-heading-5 a:visited { color: #660000; } diff --git a/src/suite.lisp b/src/suite.lisp new file mode 100644 index 000000000..8497a9d12 --- /dev/null +++ b/src/suite.lisp @@ -0,0 +1,140 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +(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. + +;;;; ** Current Suite + +(defvar *suite* nil + "The current test suite object") +(net.didierverna.asdf-flv:set-file-local-variable *suite*) + +;;;; ** Creating Suits + +;; Suites that have no parent suites. +(defvar *toplevel-suites* nil) + +(defgeneric suite-emptyp (suite) + (:method ((suite symbol)) + (suite-emptyp (get-test suite))) + (:method ((suite test-suite)) + (= 0 (hash-table-count (tests suite))))) + +(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 parent-suite))) + "Create a new test suite object. + +Overrides any existing suite named NAME." + (let ((suite (make-instance 'test-suite :name name))) + (when description + (setf (description suite) description)) + (when (and name + (null (name *suite*)) + (null parent-suite)) + (pushnew name *toplevel-suites*)) + (loop for i in (ensure-list parent-suite) + 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)) + +(eval-when (:load-toplevel :execute) + (setf *suite* + (setf (get-test 'nil) + (make-suite 'nil :description "Global Suite")))) + +(defun list-all-suites () + "Returns an unordered LIST of all suites." + (hash-table-values *suite*)) + +;;;; ** Managing the Current Suite + +(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." + `(eval-when (:compile-toplevel :load-toplevel :execute) + (%in-suite ,suite-name :in ,in :fail-on-error nil))) + +(defmacro %in-suite (suite-name &key (fail-on-error t) in) + (with-gensyms (suite) + `(progn + (if-let (,suite (get-test ',suite-name)) + (setf *suite* ,suite) + (progn + (when ,fail-on-error + (cerror "Create a new suite named ~A." + "Unknown 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 diff --git a/src/test.lisp b/src/test.lisp new file mode 100644 index 000000000..4a6f2fee9 --- /dev/null +++ b/src/test.lisp @@ -0,0 +1,167 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +(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. + +(declaim (special *suite*)) + +(defvar *test* + (make-hash-table :test 'eql) + "Lookup table mapping test (and test suite) + names to objects.") + +(defun get-test (key &optional default) + (gethash key *test* default)) + +(defun (setf get-test) (value key) + (setf (gethash key *test*) value)) + +(defun rem-test (key) + (remhash key *test*)) + +(defun test-names () + (hash-table-keys *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 fixture to wrap the body in. + +If PROFILE is T profiling information will be collected as well." + (destructuring-bind (name &rest args) + (ensure-list name) + `(def-test ,name (,@args) ,@body))) + +(defvar *default-test-compilation-time* :definition-time) + +(defmacro def-test (name (&key depends-on (suite '*suite* suite-p) fixture + (compile-at *default-test-compilation-time*) profile) + &body body) + "Create a test named NAME. + +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 fixture to wrap the body in. + +If PROFILE is T profiling information will be collected as well." + (check-type compile-at (member :run-time :definition-time)) + (multiple-value-bind (forms decls docstring) + (parse-body body :documentation t :whole name) + (let* ((description (or docstring "")) + (body-forms (append decls forms)) + (suite-form (if suite-p + `(get-test ',suite) + (or suite '*suite*))) + (effective-body (if fixture + (destructuring-bind (name &rest args) + (ensure-list fixture) + `((with-fixture ,name ,args ,@body-forms))) + body-forms))) + `(progn + (register-test ',name ,description ',effective-body ,suite-form ',depends-on ,compile-at ,profile) + (when *run-test-when-defined* + (run! ',name)) + ',name)))) + +(defun register-test (name description body suite depends-on compile-at profile) + (let ((lambda-name + (format-symbol t "%~A-~A" '#:test name)) + (inner-lambda-name + (format-symbol t "%~A-~A" '#:inner-test name))) + (setf (get-test name) + (make-instance 'test-case + :name name + :runtime-package (find-package (package-name *package*)) + :test-lambda + (eval + `(named-lambda ,lambda-name () + ,@(ecase compile-at + (:run-time `((funcall + (let ((*package* (find-package ',(package-name *package*)))) + (compile ',inner-lambda-name + '(lambda () ,@body)))))) + (:definition-time body)))) + :description description + :depends-on depends-on + :collect-profiling-info profile)) + (setf (gethash name (tests suite)) 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. diff --git a/src/utils.lisp b/src/utils.lisp new file mode 100644 index 000000000..49d552fa0 --- /dev/null +++ b/src/utils.lisp @@ -0,0 +1,226 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +(in-package :it.bese.fiveam) + +(defmacro dolist* ((iterator list &optional return-value) &body body) + "Like DOLIST but destructuring-binds the elements of LIST. + +If ITERATOR is a symbol then dolist* is just like dolist EXCEPT +that it creates a fresh binding." + (if (listp iterator) + (let ((i (gensym "DOLIST*-I-"))) + `(dolist (,i ,list ,return-value) + (destructuring-bind ,iterator ,i + ,@body))) + `(dolist (,iterator ,list ,return-value) + (let ((,iterator ,iterator)) + ,@body)))) + +(defun make-collector (&optional initial-value) + "Create a collector function. + +A Collector function will collect, into a list, all the values +passed to it in the order in which they were passed. If the +callector function is called without arguments it returns the +current list of values." + (let ((value initial-value) + (cdr (last initial-value))) + (lambda (&rest items) + (if items + (progn + (if value + (if cdr + (setf (cdr cdr) items + cdr (last items)) + (setf cdr (last items))) + (setf value items + cdr (last items))) + items) + value)))) + +(defun partitionx (list &rest lambdas) + (let ((collectors (mapcar (lambda (l) + (cons (if (and (symbolp l) + (member l (list :otherwise t) + :test #'string=)) + (constantly t) + l) + (make-collector))) + lambdas))) + (dolist (item list) + (block item + (dolist* ((test-func . collector-func) collectors) + (when (funcall test-func item) + (funcall collector-func item) + (return-from item))))) + (mapcar #'funcall (mapcar #'cdr collectors)))) + +;;;; ** Anaphoric conditionals + +(defmacro if-bind (var test &body then/else) + "Anaphoric IF control structure. + +VAR (a symbol) will be bound to the primary value of TEST. If +TEST returns a true value then THEN will be executed, otherwise +ELSE will be executed." + (assert (first then/else) + (then/else) + "IF-BIND missing THEN clause.") + (destructuring-bind (then &optional else) + then/else + `(let ((,var ,test)) + (if ,var ,then ,else)))) + +(defmacro aif (test then &optional else) + "Just like IF-BIND but the var is always IT." + `(if-bind it ,test ,then ,else)) + +;;;; ** Simple list matching based on code from Paul Graham's On Lisp. + +(defmacro acond2 (&rest clauses) + (if (null clauses) + nil + (with-gensyms (val foundp) + (destructuring-bind ((test &rest progn) &rest others) + clauses + `(multiple-value-bind (,val ,foundp) + ,test + (if (or ,val ,foundp) + (let ((it ,val)) + (declare (ignorable it)) + ,@progn) + (acond2 ,@others))))))) + +(defun varsymp (x) + (and (symbolp x) + (let ((name (symbol-name x))) + (and (>= (length name) 2) + (char= (char name 0) #\?))))) + +(defun binding (x binds) + (labels ((recbind (x binds) + (aif (assoc x binds) + (or (recbind (cdr it) binds) + it)))) + (let ((b (recbind x binds))) + (values (cdr b) b)))) + +(defun list-match (x y &optional binds) + (acond2 + ((or (eql x y) (eql x '_) (eql y '_)) + (values binds t)) + ((binding x binds) (list-match it y binds)) + ((binding y binds) (list-match x it binds)) + ((varsymp x) (values (cons (cons x y) binds) t)) + ((varsymp y) (values (cons (cons y x) binds) t)) + ((and (consp x) (consp y) (list-match (car x) (car y) binds)) + (list-match (cdr x) (cdr y) it)) + (t (values nil nil)))) + +(defun vars (match-spec) + (let ((vars nil)) + (labels ((find-vars (spec) + (cond + ((null spec) nil) + ((varsymp spec) (push spec vars)) + ((consp spec) + (find-vars (car spec)) + (find-vars (cdr spec)))))) + (find-vars match-spec)) + (delete-duplicates vars))) + +(defmacro list-match-case (target &body clauses) + (if clauses + (destructuring-bind ((test &rest progn) &rest others) + clauses + (with-gensyms (tgt binds success) + `(let ((,tgt ,target)) + (multiple-value-bind (,binds ,success) + (list-match ,tgt ',test) + (declare (ignorable ,binds)) + (if ,success + (let ,(mapcar (lambda (var) + `(,var (cdr (assoc ',var ,binds)))) + (vars test)) + (declare (ignorable ,@(vars test))) + ,@progn) + (list-match-case ,tgt ,@others)))))) + nil)) + +;;;; * def-special-environment + +(defun check-required (name vars required) + (dolist (var required) + (assert (member var vars) + (var) + "Unrecognized symbol ~S in ~S." var name))) + +(defmacro def-special-environment (name (&key accessor binder binder*) + &rest vars) + "Define two macros for dealing with groups or related special variables. + +ACCESSOR is defined as a macro: (defmacro ACCESSOR (VARS &rest +BODY)). Each element of VARS will be bound to the +current (dynamic) value of the special variable. + +BINDER is defined as a macro for introducing (and binding new) +special variables. It is basically a readable LET form with the +prorpe declarations appended to the body. The first argument to +BINDER must be a form suitable as the first argument to LET. + +ACCESSOR defaults to a new symbol in the same package as NAME +which is the concatenation of \"WITH-\" NAME. BINDER is built as +\"BIND-\" and BINDER* is BINDER \"*\"." + (unless accessor + (setf accessor (format-symbol (symbol-package name) "~A-~A" '#:with name))) + (unless binder + (setf binder (format-symbol (symbol-package name) "~A-~A" '#:bind name))) + (unless binder* + (setf binder* (format-symbol (symbol-package binder) "~A~A" binder '#:*))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (flet () + (defmacro ,binder (requested-vars &body body) + (check-required ',name ',vars (mapcar #'car requested-vars)) + `(let ,requested-vars + (declare (special ,@(mapcar #'car requested-vars))) + ,@body)) + (defmacro ,binder* (requested-vars &body body) + (check-required ',name ',vars (mapcar #'car requested-vars)) + `(let* ,requested-vars + (declare (special ,@(mapcar #'car requested-vars))) + ,@body)) + (defmacro ,accessor (requested-vars &body body) + (check-required ',name ',vars requested-vars) + `(locally (declare (special ,@requested-vars)) + ,@body)) + ',name))) + +;; Copyright (c) 2002-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 diff --git a/t/example.lisp b/t/example.lisp new file mode 100644 index 000000000..c949511a2 --- /dev/null +++ b/t/example.lisp @@ -0,0 +1,126 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +;;;; * 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) diff --git a/t/tests.lisp b/t/tests.lisp new file mode 100644 index 000000000..ed1c565e7 --- /dev/null +++ b/t/tests.lisp @@ -0,0 +1,280 @@ +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- + +(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 + +(def-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)) + +(def-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)) + +(def-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)))) + +(def-test signals/finishes () + (signals error + (error "an error")) + (finishes + (signals error + (error "an error")))) + +(def-test pass () + (pass)) + +(def-test fail1 (:suite test-suite) + (fail "This is supposed to fail")) + +(def-test fail () + (with-test-results (results fail1) + (is (= 1 (length results))) + (is (test-failure-p (first results))))) + +;;;; non top level checks + +(def-test foo-bar () + (let ((state 0)) + (is (= 0 state)) + (is (= 1 (incf state))))) + +;;;; Test dependencies + +(def-test ok (:suite test-suite) + (pass)) + +(def-test not-ok (:suite test-suite) + (fail "This is supposed to fail.")) + +(def-test and1 (:depends-on (and ok not-ok) :suite test-suite) + (fail)) + +(def-test and2 (:depends-on (and ok) :suite test-suite) + (pass)) + +(def-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)))) + +(def-test or1 (:depends-on (or ok not-ok) :suite test-suite) + (pass)) + +(def-test or2 (:depends-on (or not-ok ok) :suite test-suite) + (pass)) + +(def-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)))))) + +(def-test not1 (:depends-on (not not-ok) :suite test-suite) + (pass)) + +(def-test not2 (:depends-on (not ok) :suite test-suite) + (fail)) + +(def-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)))) + +(def-test nested-logic (:depends-on (and ok (not not-ok) (not not-ok)) + :suite test-suite) + (pass)) + +(def-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)))))) + +(def-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.")) + +(def-test circular-1 (:depends-on (and circular-2) + :suite test-suite) + (fail "we have a circular depednency, we should not be tested.")) + +(def-test circular-2 (:depends-on (and circular-1) + :suite test-suite) + (fail "we have a circular depednency, we should not be tested.")) + +(def-test circular () + (signals circular-dependency + (run 'circular-0)) + (signals circular-dependency + (run 'circular-1)) + (signals circular-dependency + (run 'circular-2))) + + +(defun stack-exhaust () + (declare (optimize (debug 3) (speed 0) (space 0) (safety 3))) + (cons 42 (stack-exhaust))) + +;; Disable until we determine on which implementations it's actually safe +;; to exhaust the stack. +#| +(def-test stack-exhaust (:suite test-suite) + (stack-exhaust)) + +(def-test test-stack-exhaust () + (with-test-results (results stack-exhaust) + (is (= 1 (length results))) + (is (test-failure-p (first results))))) +|# + +(def-suite before-test-suite :description "Suite for before test") + +(def-test before-0 (:suite before-test-suite) + (fail)) + +(def-test before-1 (:depends-on (:before before-0) + :suite before-test-suite) + (pass)) + +(def-suite before-test-suite-2 :description "Suite for before test") + +(def-test before-2 (:depends-on (:before before-3) + :suite before-test-suite-2) + (pass)) + +(def-test before-3 (:suite before-test-suite-2) + (pass)) + +(def-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 +(def-test dep-with-symbol-first (:suite test-suite) + (pass)) + +(def-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")) + +(def-test dep-with-symbol-depends-on-ok (:depends-on dep-with-symbol-first :suite test-suite) + (pass)) + +(def-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 because I depend on a test that in its turn has a failed dependecy.")) + +(def-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 + +(def-test gen-integer () + (for-all ((a (gen-integer))) + (is (integerp a)))) + +(def-test for-all-guarded () + (for-all ((less (gen-integer)) + (more (gen-integer) (< less more))) + (is (< less more)))) + +(def-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))) + +(def-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 #\! #\" #\# #\$ #\% #\& #\' #\()))) + +(def-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))) + +(def-test for-all-destructuring-bind () + (for-all (((a b) (dummy-mv-generator))) + (is (= 1 a)) + (is (= 1 b)))) + +(def-test return-values () + "Return values indicate test failures." + (is-true (with-*test-dribble* nil (explain! (run 'is1)))) + (is-true (with-*test-dribble* nil (run! 'is1))) + + (is-false (with-*test-dribble* nil (explain! (run 'is2)))) + (is-false (with-*test-dribble* nil (run! 'is2)))) diff --git a/version.sexp b/version.sexp new file mode 100644 index 000000000..e0e0284e6 --- /dev/null +++ b/version.sexp @@ -0,0 +1,2 @@ +;; -*- lisp -*- +"1.4.1"