src/test.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2
   3 (in-package :it.bese.fiveam)
   4
   5 ;;;; * Tests
   6
   7 ;;;; While executing checks and collecting the results is the core job
   8 ;;;; of a testing framework it is also important to be able to
   9 ;;;; organize checks into groups, fiveam provides two mechanisms for
  10 ;;;; organizing checks: tests and test suites. A test is a named
  11 ;;;; collection of checks which can be run and a test suite is a named
  12 ;;;; collection of tests and test suites.
  13
  14 (declaim (special *suite*))
  15
  16 (defvar *test*
  17   (make-hash-table :test 'eql)
  18   "Lookup table mapping test (and test suite)
  19   names to objects.")
  20
  21 (defun get-test (key &optional default)
  22   (gethash key *test* default))
  23
  24 (defun (setf get-test) (value key)
  25   (setf (gethash key *test*) value))
  26
  27 (defun rem-test (key)
  28   (remhash key *test*))
  29
  30 (defun test-names ()
  31   (hash-table-keys *test*))
  32
  33 (defmacro test (name &body body)
  34   "Create a test named NAME. If NAME is a list it must be of the
  35 form:
  36
  37   (name &key depends-on suite fixture compile-at profile)
  38
  39 NAME is the symbol which names the test.
  40
  41 DEPENDS-ON is a list of the form:
  42
  43  (AND . test-names) - This test is run only if all of the tests
  44  in TEST-NAMES have passed, otherwise a single test-skipped
  45  result is generated.
  46
  47  (OR . test-names) - If any of TEST-NAMES has passed this test is
  48  run, otherwise a test-skipped result is generated.
  49
  50  (NOT test-name) - This is test is run only if TEST-NAME failed.
  51
  52 AND, OR and NOT can be combined to produce complex dependencies.
  53
  54 If DEPENDS-ON is a symbol it is interpreted as `(AND
  55 ,depends-on), this is accomadate the common case of one test
  56 depending on another.
  57
  58 FIXTURE specifies a fixture to wrap the body in.
  59
  60 If PROFILE is T profiling information will be collected as well."
  61   (destructuring-bind (name &rest args)
  62       (ensure-list name)
  63     `(def-test ,name (,@args) ,@body)))
  64
  65 (defmacro def-test (name (&key depends-on (suite '*suite* suite-p) fixture
  66                             (compile-at :run-time) profile)
  67                     &body body)
  68   "Create a test named NAME.
  69
  70 NAME is the symbol which names the test.
  71
  72 DEPENDS-ON is a list of the form:
  73
  74  (AND . test-names) - This test is run only if all of the tests
  75  in TEST-NAMES have passed, otherwise a single test-skipped
  76  result is generated.
  77
  78  (OR . test-names) - If any of TEST-NAMES has passed this test is
  79  run, otherwise a test-skipped result is generated.
  80
  81  (NOT test-name) - This is test is run only if TEST-NAME failed.
  82
  83 AND, OR and NOT can be combined to produce complex dependencies.
  84
  85 If DEPENDS-ON is a symbol it is interpreted as `(AND
  86 ,depends-on), this is accomadate the common case of one test
  87 depending on another.
  88
  89 FIXTURE specifies a fixture to wrap the body in.
  90
  91 If PROFILE is T profiling information will be collected as well."
  92   (check-type compile-at (member :run-time :definition-time))
  93   (multiple-value-bind (forms decls docstring)
  94       (parse-body body :documentation t :whole name)
  95     (let* ((description (or docstring ""))
  96            (body-forms (append decls forms))
  97            (suite-form (if suite-p
  98                            `(get-test ',suite)
  99                            (or suite '*suite*)))
 100            (effective-body (if fixture
 101                                (destructuring-bind (name &rest args)
 102                                    (ensure-list fixture)
 103                                  `((with-fixture ,name ,args ,@body-forms)))
 104                                body-forms)))
 105       `(progn
 106          (register-test ',name ,description ',effective-body ,suite-form ',depends-on ,compile-at ,profile)
 107          (when *run-test-when-defined*
 108            (run! ',name))
 109          ',name))))
 110
 111 (defun register-test (name description body suite depends-on compile-at profile)
 112   (let ((lambda-name
 113           (format-symbol t "%~A-~A" '#:test name))
 114         (inner-lambda-name
 115           (format-symbol t "%~A-~A" '#:inner-test name)))
 116     (setf (get-test name)
 117           (make-instance 'test-case
 118                          :name name
 119                          :runtime-package (find-package (package-name *package*))
 120                          :test-lambda
 121                          (eval
 122                           `(named-lambda ,lambda-name ()
 123                              ,@(ecase compile-at
 124                                  (:run-time `((funcall
 125                                                (let ((*package* (find-package ',(package-name *package*))))
 126                                                  (compile ',inner-lambda-name
 127                                                           '(lambda () ,@body))))))
 128                                  (:definition-time body))))
 129                          :description description
 130                          :depends-on depends-on
 131                          :collect-profiling-info profile))
 132     (setf (gethash name (tests suite)) name)))
 133
 134 (defvar *run-test-when-defined* nil
 135   "When non-NIL tests are run as soon as they are defined.")
 136
 137 ;; Copyright (c) 2002-2003, Edward Marco Baringer
 138 ;; All rights reserved.
 139 ;;
 140 ;; Redistribution and use in source and binary forms, with or without
 141 ;; modification, are permitted provided that the following conditions are
 142 ;; met:
 143 ;;
 144 ;;  - Redistributions of source code must retain the above copyright
 145 ;;    notice, this list of conditions and the following disclaimer.
 146 ;;
 147 ;;  - Redistributions in binary form must reproduce the above copyright
 148 ;;    notice, this list of conditions and the following disclaimer in the
 149 ;;    documentation and/or other materials provided with the distribution.
 150 ;;
 151 ;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
 152 ;;    of its contributors may be used to endorse or promote products
 153 ;;    derived from this software without specific prior written permission.
 154 ;;
 155 ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 156 ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 157 ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 158 ;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
 159 ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 160 ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 161 ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 162 ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 163 ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 164 ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 165 ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.