Squashed 'third_party/lisp/fiveam/' content from commit ee9456a2
git-subtree-dir: third_party/lisp/fiveam git-subtree-split: ee9456a2ac52b1c9f5f5f789d263f0f76a15176c
This commit is contained in:
Vincent Ambo
commit
728a186263
20 changed files with 2596 additions and 0 deletions
14
.boring
Normal file
14
.boring
Normal file
|
|
@ -0,0 +1,14 @@
|
|||
# Boring file regexps:
|
||||
\#
|
||||
~$
|
||||
(^|/)_darcs($|/)
|
||||
\.dfsl$
|
||||
\.ppcf$
|
||||
\.fasl$
|
||||
\.x86f$
|
||||
\.fas$
|
||||
\.lib$
|
||||
^docs/html($|/)
|
||||
^docs/pdf($|/)
|
||||
^\{arch\}$
|
||||
(^|/).arch-ids($|/)
|
||||
47
.travis.yml
Normal file
47
.travis.yml
Normal file
|
|
@ -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
|
||||
30
COPYING
Normal file
30
COPYING
Normal file
|
|
@ -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.
|
||||
|
||||
8
README
Normal file
8
README
Normal file
|
|
@ -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.
|
||||
13
docs/make-qbook.lisp
Normal file
13
docs/make-qbook.lisp
Normal file
|
|
@ -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)))))
|
||||
|
||||
|
||||
|
||||
36
fiveam.asd
Normal file
36
fiveam.asd
Normal file
|
|
@ -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 <mb@bese.it>"
|
||||
: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 <mb@bese.it>"
|
||||
: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"
|
||||
311
src/check.lisp
Normal file
311
src/check.lisp
Normal file
|
|
@ -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
|
||||
128
src/classes.lisp
Normal file
128
src/classes.lisp
Normal file
|
|
@ -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
|
||||
133
src/explain.lisp
Normal file
133
src/explain.lisp
Normal file
|
|
@ -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
|
||||
82
src/fixture.lisp
Normal file
82
src/fixture.lisp
Normal file
|
|
@ -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.
|
||||
139
src/package.lisp
Normal file
139
src/package.lisp
Normal file
|
|
@ -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
|
||||
;;;; <mb@bese.it> and generated by qbook.
|
||||
|
||||
;;;; ** COPYRIGHT
|
||||
|
||||
;;;; Copyright (c) 2002-2003, Edward Marco Baringer
|
||||
;;;; All rights reserved.
|
||||
|
||||
;;;; Redistribution and use in source and binary forms, with or without
|
||||
;;;; modification, are permitted provided that the following conditions are
|
||||
;;;; met:
|
||||
|
||||
;;;; - Redistributions of source code must retain the above copyright
|
||||
;;;; notice, this list of conditions and the following disclaimer.
|
||||
|
||||
;;;; - Redistributions in binary form must reproduce the above copyright
|
||||
;;;; notice, this list of conditions and the following disclaimer in the
|
||||
;;;; documentation and/or other materials provided with the distribution.
|
||||
|
||||
;;;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
|
||||
;;;; of its contributors may be used to endorse or promote products
|
||||
;;;; derived from this software without specific prior written permission.
|
||||
|
||||
;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
;;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE
|
||||
265
src/random.lisp
Normal file
265
src/random.lisp
Normal file
|
|
@ -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.
|
||||
385
src/run.lisp
Normal file
385
src/run.lisp
Normal file
|
|
@ -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 "~@<Rerun the test ~S~@:>" test))
|
||||
(return-from run-it (run-it)))
|
||||
(ignore ()
|
||||
:report (lambda (stream)
|
||||
(format stream "~@<Signal an exceptional test failure and abort the test ~S.~@:>" test))
|
||||
(abort-test (make-instance 'test-failure :test-case test
|
||||
:reason "Failure restart."))))
|
||||
result-list))))
|
||||
(let ((results (run-it)))
|
||||
(setf (status test) (results-status results)
|
||||
result-list (nconc result-list results)))))))
|
||||
|
||||
(defgeneric %run (test-spec)
|
||||
(:documentation "Internal method for running a test. Does not
|
||||
update the status of the tests nor the special 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.
|
||||
64
src/style.css
Normal file
64
src/style.css
Normal file
|
|
@ -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; }
|
||||
140
src/suite.lisp
Normal file
140
src/suite.lisp
Normal file
|
|
@ -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
|
||||
167
src/test.lisp
Normal file
167
src/test.lisp
Normal file
|
|
@ -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.
|
||||
226
src/utils.lisp
Normal file
226
src/utils.lisp
Normal file
|
|
@ -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
|
||||
126
t/example.lisp
Normal file
126
t/example.lisp
Normal file
|
|
@ -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)
|
||||
280
t/tests.lisp
Normal file
280
t/tests.lisp
Normal file
|
|
@ -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))))
|
||||
2
version.sexp
Normal file
2
version.sexp
Normal file
|
|
@ -0,0 +1,2 @@
|
|||
;; -*- lisp -*-
|
||||
"1.4.1"
|
||||
Loading…
Reference in a new issue