From 168a8cb290c6d9b3fa40e500fd044ecacebb5429 Mon Sep 17 00:00:00 2001
From: Marco Baringer <mb@bese.it>
Date: Fri, 23 Mar 2007 20:56:25 +0100
Subject: [PATCH] Added :default-test-args parameter to def-suite.
---
src/classes.lisp | 6 ++++-
src/packages.lisp | 1 +
src/suite.lisp | 21 +++++++++------
src/test.lisp | 73 +++++++++++++++++++++++++++--------------------------
t/tests.lisp | 9 +++++--
5 files changed, 63 insertions(+), 47 deletions(-)
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)))
--
1.7.10.4