chore(3p/lisp): use nixpkgs sources for fiveam
Change-Id: Id0613ace9b77d3ad46cdf2366e84d026d1158ace Reviewed-on: https://cl.tvl.fyi/c/depot/+/4340 Autosubmit: tazjin <mail@tazj.in> Tested-by: BuildkiteCI Reviewed-by: grfn <grfn@gws.fyi>
This commit is contained in:
Vincent Ambo
clbot
parent
0784e68e20
commit
fa73841a4b
22 changed files with 29 additions and 2624 deletions
29
third_party/lisp/fiveam.nix
vendored
Normal file
29
third_party/lisp/fiveam.nix
vendored
Normal file
|
|
@ -0,0 +1,29 @@
|
||||||
|
# FiveAM is a Common Lisp testing framework.
|
||||||
|
#
|
||||||
|
# Imported from https://github.com/sionescu/fiveam.git
|
||||||
|
|
||||||
|
{ depot, pkgs, ... }:
|
||||||
|
|
||||||
|
let src = with pkgs; srcOnly lispPackages.fiveam;
|
||||||
|
in depot.nix.buildLisp.library {
|
||||||
|
name = "fiveam";
|
||||||
|
|
||||||
|
deps = with depot.third_party.lisp; [
|
||||||
|
alexandria
|
||||||
|
asdf-flv
|
||||||
|
trivial-backtrace
|
||||||
|
];
|
||||||
|
|
||||||
|
srcs = map (f: src + ("/src/" + f)) [
|
||||||
|
"package.lisp"
|
||||||
|
"utils.lisp"
|
||||||
|
"check.lisp"
|
||||||
|
"fixture.lisp"
|
||||||
|
"classes.lisp"
|
||||||
|
"random.lisp"
|
||||||
|
"test.lisp"
|
||||||
|
"explain.lisp"
|
||||||
|
"suite.lisp"
|
||||||
|
"run.lisp"
|
||||||
|
];
|
||||||
|
}
|
||||||
14
third_party/lisp/fiveam/.boring
vendored
14
third_party/lisp/fiveam/.boring
vendored
|
|
@ -1,14 +0,0 @@
|
||||||
# Boring file regexps:
|
|
||||||
\#
|
|
||||||
~$
|
|
||||||
(^|/)_darcs($|/)
|
|
||||||
\.dfsl$
|
|
||||||
\.ppcf$
|
|
||||||
\.fasl$
|
|
||||||
\.x86f$
|
|
||||||
\.fas$
|
|
||||||
\.lib$
|
|
||||||
^docs/html($|/)
|
|
||||||
^docs/pdf($|/)
|
|
||||||
^\{arch\}$
|
|
||||||
(^|/).arch-ids($|/)
|
|
||||||
47
third_party/lisp/fiveam/.travis.yml
vendored
47
third_party/lisp/fiveam/.travis.yml
vendored
|
|
@ -1,47 +0,0 @@
|
||||||
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
third_party/lisp/fiveam/COPYING
vendored
30
third_party/lisp/fiveam/COPYING
vendored
|
|
@ -1,30 +0,0 @@
|
||||||
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
third_party/lisp/fiveam/README
vendored
8
third_party/lisp/fiveam/README
vendored
|
|
@ -1,8 +0,0 @@
|
||||||
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.
|
|
||||||
28
third_party/lisp/fiveam/default.nix
vendored
28
third_party/lisp/fiveam/default.nix
vendored
|
|
@ -1,28 +0,0 @@
|
||||||
# FiveAM is a Common Lisp testing framework.
|
|
||||||
#
|
|
||||||
# Imported from https://github.com/sionescu/fiveam.git
|
|
||||||
|
|
||||||
{ depot, ... }:
|
|
||||||
|
|
||||||
depot.nix.buildLisp.library {
|
|
||||||
name = "fiveam";
|
|
||||||
|
|
||||||
deps = with depot.third_party.lisp; [
|
|
||||||
alexandria
|
|
||||||
asdf-flv
|
|
||||||
trivial-backtrace
|
|
||||||
];
|
|
||||||
|
|
||||||
srcs = [
|
|
||||||
./src/package.lisp
|
|
||||||
./src/utils.lisp
|
|
||||||
./src/check.lisp
|
|
||||||
./src/fixture.lisp
|
|
||||||
./src/classes.lisp
|
|
||||||
./src/random.lisp
|
|
||||||
./src/test.lisp
|
|
||||||
./src/explain.lisp
|
|
||||||
./src/suite.lisp
|
|
||||||
./src/run.lisp
|
|
||||||
];
|
|
||||||
}
|
|
||||||
13
third_party/lisp/fiveam/docs/make-qbook.lisp
vendored
13
third_party/lisp/fiveam/docs/make-qbook.lisp
vendored
|
|
@ -1,13 +0,0 @@
|
||||||
(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
third_party/lisp/fiveam/fiveam.asd
vendored
36
third_party/lisp/fiveam/fiveam.asd
vendored
|
|
@ -1,36 +0,0 @@
|
||||||
;;;; -*- 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
third_party/lisp/fiveam/src/check.lisp
vendored
311
third_party/lisp/fiveam/src/check.lisp
vendored
|
|
@ -1,311 +0,0 @@
|
||||||
;;;; -*- 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
third_party/lisp/fiveam/src/classes.lisp
vendored
128
third_party/lisp/fiveam/src/classes.lisp
vendored
|
|
@ -1,128 +0,0 @@
|
||||||
;;;; -*- 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
third_party/lisp/fiveam/src/explain.lisp
vendored
133
third_party/lisp/fiveam/src/explain.lisp
vendored
|
|
@ -1,133 +0,0 @@
|
||||||
;;;; -*- 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
third_party/lisp/fiveam/src/fixture.lisp
vendored
82
third_party/lisp/fiveam/src/fixture.lisp
vendored
|
|
@ -1,82 +0,0 @@
|
||||||
;; -*- 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
third_party/lisp/fiveam/src/package.lisp
vendored
139
third_party/lisp/fiveam/src/package.lisp
vendored
|
|
@ -1,139 +0,0 @@
|
||||||
;;;; -*- 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
third_party/lisp/fiveam/src/random.lisp
vendored
265
third_party/lisp/fiveam/src/random.lisp
vendored
|
|
@ -1,265 +0,0 @@
|
||||||
;;;; -*- 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
third_party/lisp/fiveam/src/run.lisp
vendored
385
third_party/lisp/fiveam/src/run.lisp
vendored
|
|
@ -1,385 +0,0 @@
|
||||||
;;;; -*- 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
third_party/lisp/fiveam/src/style.css
vendored
64
third_party/lisp/fiveam/src/style.css
vendored
|
|
@ -1,64 +0,0 @@
|
||||||
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
third_party/lisp/fiveam/src/suite.lisp
vendored
140
third_party/lisp/fiveam/src/suite.lisp
vendored
|
|
@ -1,140 +0,0 @@
|
||||||
;;;; -*- 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
third_party/lisp/fiveam/src/test.lisp
vendored
167
third_party/lisp/fiveam/src/test.lisp
vendored
|
|
@ -1,167 +0,0 @@
|
||||||
;;;; -*- 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
third_party/lisp/fiveam/src/utils.lisp
vendored
226
third_party/lisp/fiveam/src/utils.lisp
vendored
|
|
@ -1,226 +0,0 @@
|
||||||
;;;; -*- 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
third_party/lisp/fiveam/t/example.lisp
vendored
126
third_party/lisp/fiveam/t/example.lisp
vendored
|
|
@ -1,126 +0,0 @@
|
||||||
;;;; -*- 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
third_party/lisp/fiveam/t/tests.lisp
vendored
280
third_party/lisp/fiveam/t/tests.lisp
vendored
|
|
@ -1,280 +0,0 @@
|
||||||
;;;; -*- 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
third_party/lisp/fiveam/version.sexp
vendored
2
third_party/lisp/fiveam/version.sexp
vendored
|
|
@ -1,2 +0,0 @@
|
||||||
;; -*- lisp -*-
|
|
||||||
"1.4.1"
|
|
||||||
Loading…
Reference in a new issue