From: Marco Baringer Date: Fri, 23 Mar 2007 19:56:25 +0000 (+0100) Subject: Added :default-test-args parameter to def-suite. X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=168a8cb290c6d9b3fa40e500fd044ecacebb5429;p=fiveam.git Added :default-test-args parameter to def-suite. --- diff --git a/src/classes.lisp b/src/classes.lisp index 964b8db..7d929de 100644 --- a/src/classes.lisp +++ b/src/classes.lisp @@ -25,7 +25,11 @@ ((tests :accessor tests :initform (make-hash-table :test 'eql) :documentation "The hash table mapping names to test objects in this suite. The values in this hash table - can be either test-cases or other test-suites.")) + can be either test-cases or other test-suites.") + (default-test-args :accessor default-test-args :initform '() + :initarg :default-test-args + :documentation "Arguments passed to TEST + macro when using this suite.")) (:documentation "A test suite is a collection of tests or test suites. Test suites serve to organize tests into groups so that the diff --git a/src/packages.lisp b/src/packages.lisp index 0267a03..09b325e 100644 --- a/src/packages.lisp +++ b/src/packages.lisp @@ -1,3 +1,4 @@ + ;; -*- lisp -*- ;;;; * Introduction diff --git a/src/suite.lisp b/src/suite.lisp index e7aab24..ee4b2f6 100644 --- a/src/suite.lisp +++ b/src/suite.lisp @@ -16,24 +16,28 @@ ;;;; ** Creating Suits -(defmacro def-suite (name &key description in) +(defmacro def-suite (name &key description in default-test-args) "Define a new test-suite named NAME. IN (a symbol), if provided, causes this suite te be nested in the suite named by IN. NB: This macro is built on top of make-suite, as such it, like make-suite, will overrwrite any existing suite -named NAME." - `(progn +named NAME. + +DEFAULT-TEST-ARGS, if provided, will ba passed to the TEST forms +defined in this suite." + `(eval-when (:compile-toplevel :load-toplevel :execute) (make-suite ',name - ,@(when description `(:description ,description)) - ,@(when in `(:in ',in))) + ,@(when description `(:description ,description)) + ,@(when in `(:in ',in)) + ,@(when default-test-args `(:default-test-args ,default-test-args))) ',name)) -(defun make-suite (name &key description in) +(defun make-suite (name &key description in default-test-args) "Create a new test suite object. Overides any existing suite named NAME." - (let ((suite (make-instance 'test-suite :name name))) + (let ((suite (make-instance 'test-suite :name name :default-test-args default-test-args))) (when description (setf (description suite) description)) (loop for i in (ensure-list in) @@ -59,7 +63,8 @@ after the execution of this form are, unless specified otherwise, in the test-suite named SUITE-NAME. See also: DEF-SUITE *SUITE*" - `(%in-suite ,suite-name)) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (%in-suite ,suite-name))) (defmacro in-suite* (suite-name &key in) "Just like in-suite, but silently creates missing suites." diff --git a/src/test.lisp b/src/test.lisp index 33fa7c8..9aa1039 100644 --- a/src/test.lisp +++ b/src/test.lisp @@ -45,43 +45,44 @@ 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*. - FIXTURE specifies a fixtrue to wrap the body in." - (destructuring-bind (name &key depends-on (suite nil suite-supplied-p) - (compile-at :run-time) fixture) - (ensure-list name) - (declare (type (member :run-time :definition-time) compile-at)) - (let ((description (if (stringp (car body)) - (pop body) - "")) - (effective-body (if fixture - (destructuring-bind (name &rest args) - (ensure-list fixture) - `((with-fixture ,name ,args ,@body))) - body))) - `(progn - (setf (get-test ',name) (make-instance 'test-case - :name ',name - :runtime-package ,*package* - :test-lambda - (lambda () - ,@ (ecase compile-at - (:run-time `((funcall - (let ((*package* (find-package ',(package-name *package*)))) - (compile nil '(lambda () - ,@effective-body)))))) - (:definition-time effective-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)) - (when *run-test-when-defined* - (run! ',name)) - ',name)))) + + (let* ((tmp (gensym)) + (suite-arg (getf (cdr (ensure-list name)) :suite tmp)) + (suite (cond + ((eq tmp suite-arg) *suite*) + (t (get-test suite-arg))))) + (when (consp name) + (remf (cdr name) :suite)) + (destructuring-bind (name &key depends-on (compile-at :run-time) fixture) + (append (ensure-list name) (default-test-args suite)) + (declare (type (member :run-time :definition-time) compile-at)) + (let ((description (if (stringp (car body)) + (pop body) + "")) + (effective-body (if fixture + (destructuring-bind (name &rest args) + (ensure-list fixture) + `((with-fixture ,name ,args ,@body))) + body))) + `(progn + (setf (get-test ',name) (make-instance 'test-case + :name ',name + :runtime-package ,*package* + :test-lambda + (lambda () + ,@ (ecase compile-at + (:run-time `((funcall + (let ((*package* (find-package ',(package-name *package*)))) + (compile nil '(lambda () + ,@effective-body)))))) + (:definition-time effective-body))) + :description ,description + :depends-on ',depends-on)) + (setf (gethash ',name (tests ,suite)) ',name) + (when *run-test-when-defined* + (run! ',name)) + ',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 77909f5..47a92fc 100644 --- a/t/tests.lisp +++ b/t/tests.lisp @@ -4,12 +4,17 @@ (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." + :default-test-args '(:fixture null-fixture :compile-at :run-time)) (defmacro with-test-results ((results test-name) &body body) `(let ((,results (with-*test-dribble* nil (run ',test-name)))) ,@body)) +(def-fixture null-fixture () + `(progn ,@(&body))) + ;;;; Test the checks (test (is1 :suite test-suite) @@ -20,7 +25,7 @@ (is-true t) (is-false nil)) -(test (is2 :suite test-suite) +(test (is2 :suite test-suite :fixture foo) (is (plusp 0)) (is (< 0 -1)) (is (not (plusp 1)))