Renamed the default suite to T; allow a suite parameter of NIL to mean a test/suite...

[fiveam.git] / src / test.lisp

diff --git a/src/test.lisp b/src/test.lisp
index e4ca2d8..0bfac1f 100644 (file)
--- a/src/test.lisp
+++ b/src/test.lisp
@@ -16,8 +16,19 @@
   "Lookup table mapping test (and test suite)
   names to objects.")
 
-(defun get-test (key &optional default)
-  (gethash key *test* default))
+(defun get-test (key &key default error)
+  "Finds the test named KEY. If KEY is a testable-object (a test case
+or a test suite) then we just return KEY, otherwise we look for a test
+named KEY in the *TEST* hash table."
+  (if (testable-object-p key)
+      key
+      (multiple-value-bind (value foundp)
+          (gethash key *test*)
+        (if foundp
+            value
+            (if error
+                (error "Unable to find test named ~S." key)
+                default)))))
 
 (defun (setf get-test) (value key)
   (setf (gethash key *test*) value))
@@ -36,8 +47,11 @@
       (ensure-list name)
     `(def-test ,name (,@args) ,@body)))
 
-(defmacro def-test (name (&key depends-on (suite nil suite-p) fixture
-                            (compile-at :run-time) profile)
+(defmacro def-test (name (&key depends-on
+                               (suite nil suite-p)
+                               fixture
+                               (compile-at :run-time)
+                               profile)
                     &body body)
   "Create a test named NAME.
 
@@ -77,20 +91,38 @@ is compiled."
     (let* ((description (or docstring ""))
            (body-forms (append decls forms))
            (suite-form (if suite-p
-                           `(get-test ',suite)
+                           (if suite
+                               `(get-test ',suite)
+                               nil)
                            '*suite*))
-           (effective-body (if fixture
-                               (destructuring-bind (name &rest args)
-                                   (ensure-list fixture)
-                                 `((with-fixture ,name ,args ,@body-forms)))
-                               body-forms)))
+           (effective-body (let* ((test-fixture fixture)
+                                  (suite-fixture (if suite-p
+                                                     (if suite
+                                                         (fixture (get-test suite :error t))
+                                                         nil)
+                                                     (if *suite*
+                                                         (fixture *suite*)
+                                                         nil)))
+                                  (effective-fixture (or test-fixture suite-fixture)))
+                             (if effective-fixture
+                                 (destructuring-bind (name &rest args)
+                                     (ensure-list effective-fixture)
+                                   `((with-fixture ,name ,args ,@body-forms)))
+                                 body-forms))))
       `(progn
-         (register-test ',name ,description ',effective-body ,suite-form ',depends-on ,compile-at ,profile)
+         (register-test :name ',name
+                        :description ,description
+                        :body ',effective-body
+                        :suite ,suite-form
+                        :depends-on ',depends-on
+                        :compile-at ,compile-at
+                        :profile ,profile)
          (when *run-test-when-defined*
            (run! ',name))
          ',name))))
 
-(defun register-test (name description body suite depends-on compile-at profile)
+(defun register-test (&key name description body suite depends-on compile-at profile)
+  (remove-from-suites name)
   (let ((lambda-name
           (format-symbol t "%~A-~A" '#:test name))
         (inner-lambda-name
@@ -111,7 +143,8 @@ is compiled."
                          :description description
                          :depends-on depends-on
                          :collect-profiling-info profile))
-    (setf (gethash name (tests suite)) name)))
+    (when suite
+      (setf (gethash name (tests (get-test suite :error t))) name))))
 
 (defvar *run-test-when-defined* nil
   "When non-NIL tests are run as soon as they are defined.")