test-case.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; ID:      $Id: test-case.lisp,v 1.1 2003/08/04 16:13:58 kevin Exp $
   6 ;;;; Purpose: Test fixtures for XLUnit
   7 ;;;;
   8 ;;;; *************************************************************************
   9
  10 (in-package #:xlunit)
  11
  12
  13 (defclass test ()
  14   ())
  15
  16 (defclass test-case (test)
  17   ((existing-suites :initform nil :accessor existing-suites
  18                     :allocation :class)
  19    (method-body
  20     :initarg :method-body :accessor method-body :initform nil
  21     :documentation
  22     "A function designator which will be applied to this instance
  23 to perform that test-case.")
  24    (name :initarg :name :reader name
  25          :documentation "The name of this test-case, used in reports.")
  26    (description :initarg :description :reader description
  27                 :documentation
  28                 "Short description of this test-case, uses in reports")
  29    (suite :initform nil :accessor suite :initarg :suite))
  30   (:documentation
  31    "Base class for test-cases."))
  32
  33 (defmethod initialize-instance :after ((ob test-case) &rest initargs)
  34   (declare (ignore initargs))
  35   (if (null (existing-suites ob))
  36     (setf (existing-suites ob) (make-hash-table)))  ;;hash singleton
  37   (unless (gethash (type-of ob) (existing-suites ob))
  38     (setf (gethash (type-of ob) (existing-suites ob))
  39           (make-instance 'test-suite)))             ;;specifi suite singleton
  40   (setf (suite ob) (gethash (type-of ob) (existing-suites ob))))
  41
  42
  43 (defgeneric set-up (test)
  44   (:documentation
  45    "Method called before performing a test, should set up the
  46 environment the test-case needs to operate in."))
  47
  48 (defmethod set-up ((test test-case))
  49   )
  50
  51 (defgeneric tear-down (test)
  52   (:documentation
  53    "Method called after performing a test.  Should reverse everything
  54 that the setup method did for this instance."))
  55
  56 (defmethod tear-down ((test test-case))
  57   )
  58
  59
  60
  61 (defmethod run-on-test ((test test-case)
  62                      &key (result (make-instance 'test-result))
  63                      (handle-errors t))
  64   (start-test test result)
  65   (run-protected test result :handle-errors handle-errors)
  66   (end-test test result))
  67
  68 (defmethod run-base ((test test-case))
  69   (set-up test)
  70   (unwind-protect
  71       (run-test test)
  72     (tear-down test)))
  73
  74 (defmethod run-test ((test test-case))
  75   (funcall (method-body test)))
  76
  77 (defmethod run-protected ((test test-case) res &key (handle-errors t))
  78   (handler-case
  79       (run-base test)
  80     (assertion-failed (condition)
  81       (add-failure res test condition))
  82     (serious-condition (condition)
  83       (add-error res test condition)))
  84   res)
  85
  86
  87 (defmacro handler-case-if (test form &body cases)
  88   `(if ,test
  89        (handler-case
  90         ,form
  91         ,@cases)
  92      ,form))
  93
  94 (defmacro unwind-protect-if (test protected cleanup)
  95   `(if ,test
  96        (unwind-protect
  97            ,protected
  98          ,cleanup)
  99      (progn ,protected ,cleanup)))
 100
 101 #|
 102 (defmethod run-test ((test test-case)
 103                      &key (result (make-instance 'test-result))
 104                      (handle-errors t))
 105   "Perform the test represented by the given test-case or test-suite.
 106 Returns a test-result object."
 107   (incf (run-count result))
 108   (with-slots (failures errors) result
 109     (unwind-protect-if handle-errors
 110         (handler-case-if handle-errors
 111          (let ((res (progn (setup test)
 112                            (funcall (method-body test) test))))
 113            (when (typep res 'test-failure-condition)
 114              (push (make-test-failure test res) failures)))
 115          (test-failure-condition (failure)
 116            (push (make-test-failure test failure) failures))
 117          (error (err)
 118            (push (make-test-failure test err) errors)))
 119
 120         (if handle-errors
 121             (handler-case
 122                 (teardown test)
 123               (error (err)
 124                 (push (make-test-failure test err) errors)))
 125             (teardown test))))
 126   result)
 127 |#
 128
 129 (defun make-test (fixture name &key method-body test-suite description)
 130   "Create a test-case which is an instance of FIXTURE.  METHOD-BODY is
 131 the method that will be invoked when perfoming this test, and can be a
 132 symbol or a lambda taking a single argument, the test-case
 133 instance.  DESCRIPTION is obviously what it says it is."
 134   (let ((newtest (make-instance fixture
 135                    :name (etypecase name
 136                                 (symbol
 137                                  (string-downcase (symbol-name name)))
 138                                 (string
 139                                  name))
 140                    :method-body
 141                    (if (and (symbolp name) (null method-body))
 142                        name
 143                      method-body)
 144                    :description description)))
 145     (when test-suite (add-test newtest test-suite))
 146     newtest))