X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Ftest.lisp;h=b5e590a0b519c38ac370e9911e739af507a166a1;hb=2f4561b2f18b405c4dbb0d8326d5de60c4d54d73;hp=defb357be59678f2b967b53ea2794a7dba4fd04c;hpb=a7d389cd1eebbc3cbfae58a8885d07680eb7ae8f;p=fiveam.git diff --git a/src/test.lisp b/src/test.lisp index defb357..b5e590a 100644 --- a/src/test.lisp +++ b/src/test.lisp @@ -13,11 +13,21 @@ (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)) + "Lookup table mapping test (and test suite) names to objects.") + +(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)) @@ -30,59 +40,76 @@ collect test)) (defmacro test (name &body body) - "Deprecated. See DEF-TEST." - (simple-style-warning "~A is OBSOLETE! Use ~A instead." 'test 'def-test) + "Alias for DEF-TEST." (destructuring-bind (name &rest args) (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 (suite nil suite-p) + fixture + (compile-at :run-time) + depends-on + profile) &body body) "Create a test named NAME. -NAME is the symbol which names the test. - -DEPENDS-ON is a list of the form: +NAME (a symbol):: + The name of the test. -\(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. +SUITE (a test name):: + The suite to put the test under. It defaults to *SUITE* (which + itself defaults to the default global suite). -\(OR . test-names) - If any of TEST-NAMES has passed this test is - run, otherwise a test-skipped result is generated. +FIXTURE:: + The name of the fixture to use for this test. See `WITH-FIXTURE` for + details on fixtures. -\(NOT test-name) - This is test is run only if TEST-NAME failed. +COMPILE-AT (a keyword):: + When the body of this test should be compiled. By default, or when + `:compile-at` is `:run-time`, test bodies are only compiled before + they are run. Set this to to `:definition-time` to force + compilation, and errors/warnings, to be done at compile time. -AND, OR and NOT can be combined to produce complex dependencies. +DEPENDS-ON:: + A list, or a symbol, which specifies the relationship between this + test and other tests. These conditions, `AND`, `OR` and `NOT` can be + combined to produce complex dependencies (whethere this is something + you should actually be doing is a question for another day). -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. + `(and &rest 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. -SUITE is the suite to put the test under. It defaults to -*SUITE* (which itself defaults to the default global suite). + `(or &rest TEST-NAMES)`::: + If any of TEST-NAMES has passed this test is run, otherwise a + test-skipped result is generated. -FIXTURE specifies a fixture to wrap the body in. + `(NOT TEST-NAME`::: + This is test is run only if TEST-NAME failed. -If PROFILE is T profiling information will be collected as well. + __a-symbol__::: + Shorthand for `(AND a-symbol)` -COMPILE-AT can be either :RUN-TIME, in which case compilation of the -test code will be delayed until the test is run, or :DEFINITION-TIME, -in which case the code will be compiled when the DEF-TEST form itself -is compiled." +PROFILE:: + When non-`NIL` 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) + (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) @@ -90,12 +117,19 @@ is compiled." `((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 @@ -116,7 +150,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.")