From: Marco Baringer Date: Thu, 29 Nov 2012 11:28:22 +0000 (+0100) Subject: Renamed the default suite to T; allow a suite parameter of NIL to mean a test/suite... X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=08b391a6ecfb01d739fabaedad8557c21971b197;p=fiveam.git Renamed the default suite to T; allow a suite parameter of NIL to mean a test/suite that is not in any other 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 --- 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 --- 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 --- 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*)))))