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

Also fixed a bug where changed the test or suites :in suite (the value
in def-test and def-suite) was properly updating the tests slot of the
old suites and *suites*.

diff --git a/src/suite.lisp b/src/suite.lisp
index 2c1286d..8fd2218 100644 (file)
--- a/src/suite.lisp
+++ b/src/suite.lisp
@@ -42,10 +42,18 @@ def-test) to pass to tests in this suite."
      (def-suite ,name ,@def-suite-args)
      (in-suite ,name)))
 
-(defun make-suite (name &key description ((:in parent-suite)) fixture)
+(defun remove-from-suites (test-name)
+  (when (get-test test-name)
+    ;; if this suite alruady exists, and its :IN some other suite, remove it.
+    (dolist (s (list-all-suites))
+      (when (gethash test-name (tests s))
+        (remhash test-name (tests s))))))
+
+(defun make-suite (name &key description ((:in parent-suite) *suite*) fixture)
   "Create a new test suite object.
 
 Overrides any existing suite named NAME."
+  (remove-from-suites name)
   (let ((suite (make-instance 'test-suite :name name :fixture fixture)))
     (when description
       (setf (description suite) description))
@@ -67,8 +75,7 @@ Overrides any existing suite named NAME."
 
 ;;;; ** Managing the Current Suite
 
-(defvar *suite* (setf (get-test 'NIL)
-                      (make-suite 'NIL :description "Default global suite"))
+(defvar *suite* (setf (get-test 'T) (make-suite 'T :description "Default global suite" :in nil))
   "The current test suite object")
 
 (defmacro in-suite (suite-name)
@@ -80,11 +87,13 @@ See also: DEF-SUITE *SUITE*"
   `(eval-when (:compile-toplevel :load-toplevel :execute)
      (%in-suite ,suite-name)))
 
-(defmacro in-suite* (suite-name &key in)
+(defmacro in-suite* (suite-name &key (in nil in-p))
   "Just like in-suite, but silently creates missing suites."
-  `(%in-suite ,suite-name :in ,in :fail-on-error nil))
+  `(%in-suite ,suite-name
+              ,@(when in-p `(:in ,in))
+              :fail-on-error nil))
 
-(defmacro %in-suite (suite-name &key (fail-on-error t) in)
+(defmacro %in-suite (suite-name &key (fail-on-error t) (in nil in-p))
   (with-gensyms (suite)
     `(progn
        (if-let (,suite (get-test ',suite-name))
@@ -93,7 +102,7 @@ See also: DEF-SUITE *SUITE*"
            (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)
+           (setf (get-test ',suite-name) (make-suite ',suite-name ,@(when in-p `(:in ',in)))
                  *suite* (get-test ',suite-name))))
        ',suite-name)))
 

diff --git a/src/test.lisp b/src/test.lisp
index 3d79595..0bfac1f 100644 (file)
--- a/src/test.lisp
+++ b/src/test.lisp
@@ -47,8 +47,11 @@ named KEY in the *TEST* hash table."
       (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.
 
@@ -88,12 +91,18 @@ 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 (let* ((test-fixture fixture)
                                   (suite-fixture (if suite-p
-                                                     (fixture (get-test suite))
-                                                     (fixture *suite*)))
+                                                     (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)
@@ -113,6 +122,7 @@ is compiled."
          ',name))))
 
 (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
@@ -133,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.")

diff --git a/t/tests.lisp b/t/tests.lisp
index e03435f..27b4229 100644 (file)
--- a/t/tests.lisp
+++ b/t/tests.lisp
@@ -4,7 +4,9 @@
 
 (in-suite :it.bese.fiveam)
 
-(def-suite test-suite :description "Suite for tests which should fail.")
+(def-suite test-suite
+    :description "Suite for tests which should fail."
+    :in nil)
 
 (defmacro with-test-results ((results test-name) &body body)
   `(let ((,results (with-*test-dribble* nil (run ',test-name))))
@@ -130,15 +132,15 @@
     (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)
+                      :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)
+                      :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)
+                      :suite test-suite)
   (fail "we have a circular depednency, we should not be tested."))
 
 (def-test circular ()
@@ -150,19 +152,19 @@
     (run 'circular-2)))
 
 
-(def-suite before-test-suite :description "Suite for before test")
+(def-suite before-test-suite :description "Suite for before test" :in nil)
 
 (def-test before-0 (:suite before-test-suite)
   (pass))
 
 (def-test before-1 (:depends-on (:before before-0)
-                :suite before-test-suite)
+                    :suite before-test-suite)
   (fail))
 
-(def-suite before-test-suite-2 :description "Suite for before test")
+(def-suite before-test-suite-2 :description "Suite for before test" :in nil)
 
 (def-test before-2 (:depends-on (:before before-3)
-                :suite before-test-suite-2)
+                    :suite before-test-suite-2)
   (pass))
 
 (def-test before-3 (:suite before-test-suite-2)
@@ -274,3 +276,19 @@
 
 (def-test test-with-suite-fixture (:suite suite-with-fixture)
   (is (= 42 *special-variable*)))
+
+(def-test add-remove-test-from-suite ()
+  (let ((*test* (make-hash-table :test 'eql))
+        (*suites* (make-hash-table :test 'eql)))
+    (in-suite* empty :in nil)
+    (is (null (get-test 'foo)))
+
+    (def-test foo (:suite nil) t)
+    (is-true (get-test 'foo))
+    (is-false (gethash 'foo (tests *suite*)))
+
+    (def-test foo () t)
+    (is-true (gethash 'foo (tests *suite*)))
+
+    (def-test foo (:suite nil) t)
+    (is-false (gethash 'foo (tests *suite*)))))