Squashed 'third_party/lisp/fiveam/' content from commit ee9456a2

git-subtree-dir: third_party/lisp/fiveam
git-subtree-split: ee9456a2ac52b1c9f5f5f789d263f0f76a15176c

1 files changed, 385 insertions, 0 deletions

diff --git a/src/run.lisp b/src/run.lisp
new file mode 100644
index 000000000000..89c522351504
--- /dev/null
+++ b/src/run.lisp
@@ -0,0 +1,385 @@
+;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
+
+(in-package :it.bese.fiveam)
+
+;;;; * Running Tests
+
+;;;; Once the programmer has defined what the tests are these need to
+;;;; be run and the expected effects should be compared with the
+;;;; actual effects. FiveAM provides the function RUN for this
+;;;; purpose, RUN executes a number of tests and collects the results
+;;;; of each individual check into a list which is then
+;;;; returned. There are three types of test results: passed, failed
+;;;; and skipped, these are represented by TEST-RESULT objects.
+
+;;;; Generally running a test will return normally, but there are two
+;;;; exceptional situations which can occur:
+
+;;;; - An exception is signaled while running the test. If the
+;;;;   variable *on-error* is :DEBUG than FiveAM will enter the
+;;;;   debugger, otherwise a test failure (of type
+;;;;   unexpected-test-failure) is returned. When entering the
+;;;;   debugger two restarts are made available, one simply reruns the
+;;;;   current test and another signals a test-failure and continues
+;;;;   with the remaining tests.
+
+;;;; - A circular dependency is detected. An error is signaled and a
+;;;;   restart is made available which signals a test-skipped and
+;;;;   continues with the remaining tests. This restart also sets the
+;;;;   dependency status of the test to nil, so any tests which depend
+;;;;   on this one (even if the dependency is not circular) will be
+;;;;   skipped.
+
+;;;; The functions RUN!, !, !! and !!! are convenient wrappers around
+;;;; RUN and EXPLAIN.
+
+(deftype on-problem-action ()
+  '(member :debug :backtrace nil))
+
+(declaim (type on-problem-action *on-error* *on-failure*))
+
+(defvar *on-error* nil
+  "The action to perform on error:
+- :DEBUG if we should drop into the debugger
+- :BACKTRACE to print a backtrace
+- NIL to simply continue")
+
+(defvar *on-failure* nil
+  "The action to perform on check failure:
+- :DEBUG if we should drop into the debugger
+- :BACKTRACE to print a backtrace
+- NIL to simply continue")
+
+(defvar *debug-on-error* nil
+  "T if we should drop into the debugger on error, NIL otherwise.
+OBSOLETE: superseded by *ON-ERROR*")
+
+(defvar *debug-on-failure* nil
+  "T if we should drop into the debugger on a failing check, NIL otherwise.
+OBSOLETE: superseded by *ON-FAILURE*")
+
+(defparameter *print-names* t
+  "T if we should print test running progress, NIL otherwise.")
+
+(defparameter *test-dribble-indent* (make-array 0
+                                        :element-type 'character
+                                        :fill-pointer 0
+                                        :adjustable t)
+  "Used to indent tests and test suites in their parent suite")
+
+(defun import-testing-symbols (package-designator)
+  (import '(5am::is 5am::is-true 5am::is-false 5am::signals 5am::finishes)
+          package-designator))
+
+(defparameter *run-queue* '()
+  "List of test waiting to be run.")
+
+(define-condition circular-dependency (error)
+  ((test-case :initarg :test-case))
+  (:report (lambda (cd stream)
+             (format stream "A circular dependency wes detected in ~S." (slot-value cd 'test-case))))
+  (:documentation "Condition signaled when a circular dependency
+between test-cases has been detected."))
+
+(defgeneric run-resolving-dependencies (test)
+  (:documentation "Given a dependency spec determine if the spec
+is satisfied or not, this will generally involve running other
+tests. If the dependency spec can be satisfied the test is also
+run."))
+
+(defmethod run-resolving-dependencies ((test test-case))
+  "Return true if this test, and its dependencies, are satisfied,
+  NIL otherwise."
+  (case (status test)
+    (:unknown
+     (setf (status test) :resolving)
+     (if (or (not (depends-on test))
+             (eql t (resolve-dependencies (depends-on test))))
+         (progn
+           (run-test-lambda test)
+           (status test))
+         (with-run-state (result-list)
+           (unless (eql :circular (status test))
+             (push (make-instance 'test-skipped
+                                  :test-case test
+                                  :reason "Dependencies not satisfied")
+                   result-list)
+             (setf (status test) :depends-not-satisfied)))))
+    (:resolving
+     (restart-case
+         (error 'circular-dependency :test-case test)
+       (skip ()
+         :report (lambda (s)
+                   (format s "Skip the test ~S and all its dependencies." (name test)))
+         (with-run-state (result-list)
+           (push (make-instance 'test-skipped :reason "Circular dependencies" :test-case test)
+                 result-list))
+         (setf (status test) :circular))))
+    (t (status test))))
+
+(defgeneric resolve-dependencies (depends-on))
+
+(defmethod resolve-dependencies ((depends-on symbol))
+  "A test which depends on a symbol is interpreted as `(AND
+  ,DEPENDS-ON)."
+  (run-resolving-dependencies (get-test depends-on)))
+
+(defmethod resolve-dependencies ((depends-on list))
+  "Return true if the dependency spec DEPENDS-ON is satisfied,
+  nil otherwise."
+  (if (null depends-on)
+      t
+      (flet ((satisfies-depends-p (test)
+               (funcall test (lambda (dep)
+                               (eql t (resolve-dependencies dep)))
+                        (cdr depends-on))))
+        (ecase (car depends-on)
+          (and (satisfies-depends-p #'every))
+          (or  (satisfies-depends-p #'some))
+          (not (satisfies-depends-p #'notany))
+          (:before (every #'(lambda (dep)
+                              (let ((status (status (get-test dep))))
+                                (if (eql :unknown status)
+                                    (run-resolving-dependencies (get-test dep))
+                                    status)))
+                          (cdr depends-on)))))))
+
+(defun results-status (result-list)
+  "Given a list of test results (generated while running a test)
+  return true if no results are of type TEST-FAILURE.  Returns second
+  and third values, which are the set of failed tests and skipped
+  tests respectively."
+  (let ((failed-tests
+          (remove-if-not #'test-failure-p result-list))
+        (skipped-tests
+          (remove-if-not #'test-skipped-p result-list)))
+    (values (null failed-tests)
+            failed-tests
+            skipped-tests)))
+
+(defun return-result-list (test-lambda)
+  "Run the test function TEST-LAMBDA and return a list of all
+  test results generated, does not modify the special environment
+  variable RESULT-LIST."
+  (bind-run-state ((result-list '()))
+    (funcall test-lambda)
+    result-list))
+
+(defgeneric run-test-lambda (test))
+
+(defmethod run-test-lambda ((test test-case))
+  (with-run-state (result-list)
+    (bind-run-state ((current-test test))
+      (labels ((abort-test (e &optional (reason (format nil "Unexpected Error: ~S~%~A." e e)))
+                 (add-result 'unexpected-test-failure
+                             :test-expr nil
+                             :test-case test
+                             :reason reason
+                             :condition e))
+               (run-it ()
+                 (let ((result-list '()))
+                   (declare (special result-list))
+                   (handler-bind ((check-failure (lambda (e)
+                                                   (declare (ignore e))
+                                                   (cond
+                                                     ((eql *on-failure* :debug)
+                                                      nil)
+                                                     (t
+                                                      (when (eql *on-failure* :backtrace)
+                                                        (trivial-backtrace:print-backtrace-to-stream
+                                                         *test-dribble*))
+                                                      (invoke-restart
+                                                       (find-restart 'ignore-failure))))))
+                                  (error (lambda (e)
+                                           (unless (or (eql *on-error* :debug)
+                                                       (typep e 'check-failure))
+                                             (when (eql *on-error* :backtrace)
+                                               (trivial-backtrace:print-backtrace-to-stream
+                                                *test-dribble*))
+                                             (abort-test e)
+                                             (return-from run-it result-list)))))
+                     (restart-case
+                         (handler-case
+                             (let ((*readtable* (copy-readtable))
+                                   (*package* (runtime-package test)))
+                               (when *print-names*
+                                   (format *test-dribble* "~%~ARunning test ~A " *test-dribble-indent* (name test)))
+                               (if (collect-profiling-info test)
+                                   ;; Timing info doesn't get collected ATM, we need a portable library
+                                   ;; (setf (profiling-info test) (collect-timing (test-lambda test)))
+                                   (funcall (test-lambda test))
+                                   (funcall (test-lambda test))))
+                           (storage-condition (e)
+                             ;; heap-exhausted/constrol-stack-exhausted
+                             ;; handler-case unwinds the stack (unlike handler-bind)
+                             (abort-test e (format nil "STORAGE-CONDITION: aborted for safety. ~S~%~A." e e))
+                             (return-from run-it result-list)))
+                       (retest ()
+                         :report (lambda (stream)
+                                   (format stream "~@<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.