fixture.lisp

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