X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Ftest.lisp;h=b5e590a0b519c38ac370e9911e739af507a166a1;hb=b73b69718c49a7e5c666bab225cc0843d7c7aadb;hp=af7225a0bca77c380834263c2a145e51383de8b1;hpb=66058d990da7c0339694d0eb629f299a6c3fec3c;p=fiveam.git diff --git a/src/test.lisp b/src/test.lisp index af7225a..b5e590a 100644 --- a/src/test.lisp +++ b/src/test.lisp @@ -1,82 +1,171 @@ -;; -*- lisp -*- +;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*- -(in-package :it.bese.FiveAM) +(in-package :it.bese.fiveam) ;;;; * Tests ;;;; While executing checks and collecting the results is the core job ;;;; of a testing framework it is also important to be able to -;;;; organize checks into groups, FiveAM provides two mechanisms for +;;;; organize checks into groups, fiveam provides two mechanisms for ;;;; organizing checks: tests and test suites. A test is a named ;;;; collection of checks which can be run and a test suite is a named ;;;; collection of tests and test suites. -(deflookup-table test - :documentation "Lookup table mapping test (and test suite) - names to objects.") +(defvar *test* + (make-hash-table :test 'eql) + "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)) + +(defun rem-test (key) + (remhash key *test*)) + +(defun test-names () + (loop for test being the hash-keys of *test* + collect test)) (defmacro test (name &body body) - "Create a test named NAME. If NAME is a list it must be of the -form: - - (name &key depends-on suite) - -NAME is the symbol which names the test. - -DEPENDS-ON is a list of the form: - - (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. - - (OR . test-names) - If any of TEST-NAMES has passed this test is - run, otherwise a test-skipped result is generated. - - (NOT test-name) - This is test is run only if TEST-NAME failed. - -AND, OR and NOT can be combined to produce complex dependencies. - -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. - -SUITE defaults to the current value of *SUITE*." - (destructuring-bind (name &key depends-on (suite nil suite-supplied-p)) + "Alias for DEF-TEST." + (destructuring-bind (name &rest args) (ensure-list name) - (let (description) - (setf description (if (stringp (car body)) - (pop body) - "")) + `(def-test ,name (,@args) ,@body))) + +(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 (a symbol):: + The name of the test. + +SUITE (a test name):: + The suite to put the test under. It defaults to *SUITE* (which + itself defaults to the default global suite). + +FIXTURE:: + The name of the fixture to use for this test. See `WITH-FIXTURE` for + details on fixtures. + +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. + +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). + + `(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. + + `(or &rest TEST-NAMES)`::: + If any of TEST-NAMES has passed this test is run, otherwise a + test-skipped result is generated. + + `(NOT TEST-NAME`::: + This is test is run only if TEST-NAME failed. + + __a-symbol__::: + Shorthand for `(AND a-symbol)` + +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 + (if suite + `(get-test ',suite) + nil) + '*suite*)) + (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 - (setf (get-test ',name) (make-instance 'test-case - :name ',name - :test-lambda - (lambda () - (funcall (compile nil '(lambda () ,@body)))) - :description ,description - :depends-on ',depends-on)) - ,(if suite-supplied-p - `(setf (gethash ',name (tests (get-test ',suite))) - ',name) - `(setf (gethash ',name (tests (or *suite* (get-test 'NIL)))) - ',name)) + (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)))) + ',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 + (format-symbol t "%~A-~A" '#:inner-test name))) + (setf (get-test name) + (make-instance 'test-case + :name name + :runtime-package (find-package (package-name *package*)) + :test-lambda + (eval + `(named-lambda ,lambda-name () + ,@(ecase compile-at + (:run-time `((funcall + (let ((*package* (find-package ',(package-name *package*)))) + (compile ',inner-lambda-name + '(lambda () ,@body)))))) + (:definition-time body)))) + :description description + :depends-on depends-on + :collect-profiling-info profile)) + (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.") ;; Copyright (c) 2002-2003, Edward Marco Baringer -;; All rights reserved. -;; +;; 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. @@ -84,7 +173,7 @@ SUITE defaults to the current value of *SUITE*." ;; - 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