76d652647e91adbe42aea4b7840ec88891d7826d
[fiveam.git] / src / suite.lisp
1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
2
3 (in-package :it.bese.fiveam)
4
5 ;;;; * Test Suites
6
7 ;;;; Test suites allow us to collect multiple tests into a single
8 ;;;; object and run them all using asingle name. Test suites do not
9 ;;;; affect the way test are run nor the way the results are handled,
10 ;;;; they are simply a test organizing group.
11
12 ;;;; Test suites can contain both tests and other test suites. Running
13 ;;;; a test suite causes all of its tests and test suites to be
14 ;;;; run. Suites do not affect test dependencies, running a test suite
15 ;;;; can cause tests which are not in the suite to be run.
16
17 ;;;; ** Creating Suits
18
19 (defvar *suites* (make-hash-table :test 'eql))
20
21 (defmacro def-suite (name &key description (in nil in-p) (fixture nil fixture-p))
22   "Define a new test-suite named NAME.
23
24 NAME::
25   The symbol naming the test.
26
27 DESCRIPTION::
28   A string describing the contents/purpose of this suite.
29
30 IN (a symbol)::
31   If provided, causes this suite te be nested in the suite named by
32   `IN`. If `IN` is `NIL`, as opposed to not being passed at all, the
33   new suite will not be a part of any existing suite.
34
35 FIXTURE::
36   Whatever value is passed here will be passed, unevaluated, to all
37   tests defined in this suite.
38
39 [NOTE]
40 This macro is built on top of `make-suite` as such it, like `make-suite`,
41 will overrwrite any existing suite named `NAME`."
42   `(eval-when (:compile-toplevel :load-toplevel :execute)
43      (make-suite ',name
44                  ,@(when description `(:description ,description))
45                  ,@(when in-p      `(:in ',in))
46                  ,@(when fixture-p `(:fixture ',fixture)))
47      ',name))
48
49 (defmacro def-suite* (name &rest def-suite-args)
50   `(progn
51      (def-suite ,name ,@def-suite-args)
52      (in-suite ,name)))
53
54 (defun remove-from-suites (test-name)
55   (when (get-test test-name)
56     ;; if this suite alruady exists, and its :IN some other suite, remove it.
57     (dolist (s (list-all-suites))
58       (when (gethash test-name (tests s))
59         (remhash test-name (tests s))))))
60
61 (defun make-suite (name &key description ((:in parent-suite) *suite*) fixture)
62   "Create a new test suite object.
63
64 Overrides any existing suite named NAME."
65   (remove-from-suites name)
66   (let ((suite (make-instance 'test-suite :name name :fixture fixture)))
67     (when description
68       (setf (description suite) description))
69     (setf (gethash name *suites*) suite)
70     (loop for i in (ensure-list parent-suite)
71           for in-suite = (get-test i)
72           do (progn
73                (when (null in-suite)
74                  (cerror "Create a new suite named ~A." "Unknown suite ~A." i)
75                  (setf (get-test in-suite) (make-suite i)
76                        in-suite (get-test in-suite)))
77                (setf (gethash name (tests in-suite)) suite)))
78     (setf (get-test name) suite)
79     suite))
80
81 (defun list-all-suites ()
82   (loop for suite being the hash-value in *suites*
83        collect suite))
84
85 ;;;; ** Managing the Current Suite
86
87 (defvar *suite* (setf (get-test 'T) (make-suite 'T :description "Default global suite" :in nil))
88   "The current test suite object")
89
90 (defmacro in-suite (suite-name)
91   "Set the `*suite*` special variable so that all tests defined
92 after the execution of this form are, unless specified otherwise,
93 in the test-suite named `SUITE-NAME`.
94
95 See also: `DEF-SUITE` and `*SUITE*`. "
96   `(eval-when (:compile-toplevel :load-toplevel :execute)
97      (%in-suite ,suite-name)))
98
99 (defmacro in-suite* (suite-name &rest def-suite-args)
100   "Same effect as `IN-SUITE`, but if `SUITE-NAME` does not exist it
101 will be created (as per `DEF-SUITE`)"
102   `(%in-suite ,suite-name
103               :fail-on-error nil
104               ,@def-suite-args))
105
106 (defmacro %in-suite (suite-name &rest def-suite-args &key fail-on-error &allow-other-keys)
107   (declare (ignore fail-on-error))
108   (with-gensyms (suite)
109     (let ((fail-on-error (getf def-suite-args :fail-on-error t)))
110       (remf def-suite-args :fail-on-error)
111       `(progn
112          (if-let (,suite (get-test ',suite-name))
113            (setf *suite* ,suite)
114            (progn
115              (when ,fail-on-error
116                (cerror "Create a new suite named ~A."
117                        "Unknown suite ~A." ',suite-name))
118              (setf (get-test ',suite-name) (make-suite ',suite-name ,@def-suite-args)
119                    *suite* (get-test ',suite-name))))
120          ',suite-name))))
121
122 ;; Copyright (c) 2002-2003, Edward Marco Baringer
123 ;; All rights reserved.
124 ;;
125 ;; Redistribution and use in source and binary forms, with or without
126 ;; modification, are permitted provided that the following conditions are
127 ;; met:
128 ;;
129 ;;  - Redistributions of source code must retain the above copyright
130 ;;    notice, this list of conditions and the following disclaimer.
131 ;;
132 ;;  - Redistributions in binary form must reproduce the above copyright
133 ;;    notice, this list of conditions and the following disclaimer in the
134 ;;    documentation and/or other materials provided with the distribution.
135 ;;
136 ;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
137 ;;    of its contributors may be used to endorse or promote products
138 ;;    derived from this software without specific prior written permission.
139 ;;
140 ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
141 ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
142 ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
143 ;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
144 ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
145 ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
146 ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
147 ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
148 ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
149 ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
150 ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE