fixture.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:        fixture.lisp
   6 ;;;; Purpose:     eXtreme Lisp Test Suite
   7 ;;;; Authors:     Kevin Rosenberg and Craig Brozefsky
   8 ;;;;
   9 ;;;; $Id: fixture.lisp,v 1.1 2003/08/04 12:01:54 kevin Exp $
  10 ;;;; *************************************************************************
  11
  12 (in-package #:xlunit)
  13
  14
  15 (defclass test-fixture ()
  16   ((test-thunk
  17     :initarg :test-thunk :reader test-thunk
  18     :initform 'perform-test
  19     :documentation
  20     "A thunk or symbol which will be applied to this instance, a
  21 test-case, to perform that test-case. Defaults to 'perform-test")
  22    (test-name
  23     :initarg :test-name
  24     :reader test-name
  25     :documentation
  26     "The name of this test-case, used in reports.")
  27    (test-description
  28     :initarg :description
  29     :reader description
  30     :documentation
  31     "Short description of this test-case, uses in reports"))
  32   (:documentation
  33    "Base class for test-fixtures.  Test-cases are instances of test-fixtures."))
  34
  35 (defgeneric setup (test)
  36   (:documentation
  37    "Method called before performing a test, should set up the
  38 environment the test-case needs to operate in."))
  39
  40 (defmethod setup ((test test-fixture))
  41   t)
  42
  43 (defgeneric teardown (test)
  44   (:documentation
  45    "Method called after performing a test.  Should reverse everything
  46 that the setup method did for this instance."))
  47
  48 (defmethod teardown ((test test-fixture))
  49   t)
  50
  51
  52 (defmacro handler-case-if (test form &body cases)
  53   `(if ,test
  54        (handler-case
  55         ,form
  56         ,@cases)
  57      ,form))
  58
  59 (defmacro unwind-protect-if (test protected cleanup)
  60   `(if ,test
  61        (unwind-protect
  62            ,protected
  63          ,cleanup)
  64      (progn ,protected ,cleanup)))
  65
  66
  67 (defmethod run-test ((test test-fixture)
  68                      &key (result (make-instance 'test-result))
  69                      (handle-errors t))
  70   "Perform the test represented by the given test-case or test-suite.
  71 Returns one or more test-result objects, one for each test-case
  72 performed."
  73   (incf (test-count result))
  74   (with-slots (failures errors) result
  75     (unwind-protect-if handle-errors
  76         (handler-case-if handle-errors
  77          (let ((res (progn (setup test)
  78                            (funcall (test-thunk test) test))))
  79            (if (typep res 'test-failure-condition)
  80                (push (make-instance 'test-failure
  81                        :failed-test test
  82                        :thrown-condition res)
  83                      failures)))
  84          (test-failure-condition (failure)
  85                                  (push (make-instance 'test-failure
  86                                          :failed-test test
  87                                          :thrown-condition failure)
  88                                        failures))
  89          (error (err)
  90                 (push (make-instance 'test-failure
  91                         :failed-test test
  92                         :thrown-condition err)
  93                       errors)))
  94         (if handle-errors
  95             (handler-case
  96                 (teardown test)
  97               (error (err)
  98                 (push
  99                  (make-instance 'test-failure
 100                    :failed-test test :thrown-condition err)
 101                  errors)))
 102           (teardown test))))
 103   result)
 104
 105
 106 (defun make-test (fixture name &key test-thunk test-suite description)
 107   "Create a test-case which is an instance of FIXTURE.  TEST-THUNK is
 108 the method that will be invoked when perfoming this test, and can be a
 109 symbol or a lambda taking a single argument, the test-fixture
 110 instance.  DESCRIPTION is obviously what it says it is."
 111   (let ((newtest (make-instance fixture
 112                    :test-name (etypecase name
 113                                 (symbol
 114                                  (string-downcase (symbol-name name)))
 115                                 (string
 116                                  name))
 117                    :test-thunk
 118                    (if(and (symbolp name) (null test-thunk))
 119                        name
 120                      test-thunk)
 121                    :description description)))
 122        (if test-suite (add-test newtest test-suite))
 123        newtest))
 124