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.2 2003/08/04 16:42:27 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 (defmethod run ((ob test-case))
  60   (run-on-test-result ob (make-instance 'test-results)))
  61
  62
  63
  64 (defmethod run-on-test-result ((test test-case)
  65                      &key (result (make-instance 'test-result))
  66                      (handle-errors t))
  67   (start-test test result)
  68   (run-protected test result :handle-errors handle-errors)
  69   (end-test test result))
  70
  71 (defmethod run-base ((test test-case))
  72   (set-up test)
  73   (unwind-protect
  74       (run-test test)
  75     (tear-down test)))
  76
  77 (defmethod run-test ((test test-case))
  78   (funcall (method-body test)))
  79
  80 (defmethod run-protected ((test test-case) res &key (handle-errors t))
  81   (handler-case
  82       (run-base test)
  83     (assertion-failed (condition)
  84       (add-failure res test condition))
  85     (serious-condition (condition)
  86       (add-error res test condition)))
  87   res)
  88
  89
  90 (defmacro handler-case-if (test form &body cases)
  91   `(if ,test
  92        (handler-case
  93         ,form
  94         ,@cases)
  95      ,form))
  96
  97 (defmacro unwind-protect-if (test protected cleanup)
  98   `(if ,test
  99        (unwind-protect
 100            ,protected
 101          ,cleanup)
 102      (progn ,protected ,cleanup)))
 103
 104 #|
 105 (defmethod run-test ((test test-case)
 106                      &key (result (make-instance 'test-result))
 107                      (handle-errors t))
 108   "Perform the test represented by the given test-case or test-suite.
 109 Returns a test-result object."
 110   (incf (run-count result))
 111   (with-slots (failures errors) result
 112     (unwind-protect-if handle-errors
 113         (handler-case-if handle-errors
 114          (let ((res (progn (setup test)
 115                            (funcall (method-body test) test))))
 116            (when (typep res 'test-failure-condition)
 117              (push (make-test-failure test res) failures)))
 118          (test-failure-condition (failure)
 119            (push (make-test-failure test failure) failures))
 120          (error (err)
 121            (push (make-test-failure test err) errors)))
 122
 123         (if handle-errors
 124             (handler-case
 125                 (teardown test)
 126               (error (err)
 127                 (push (make-test-failure test err) errors)))
 128             (teardown test))))
 129   result)
 130 |#
 131
 132 (defun make-test (fixture name &key method-body test-suite description)
 133   "Create a test-case which is an instance of FIXTURE.  METHOD-BODY is
 134 the method that will be invoked when perfoming this test, and can be a
 135 symbol or a lambda taking a single argument, the test-case
 136 instance.  DESCRIPTION is obviously what it says it is."
 137   (let ((newtest (make-instance fixture
 138                    :name (etypecase name
 139                                 (symbol
 140                                  (string-downcase (symbol-name name)))
 141                                 (string
 142                                  name))
 143                    :method-body
 144                    (if (and (symbolp name) (null method-body))
 145                        name
 146                      method-body)
 147                    :description description)))
 148     (when test-suite (add-test newtest test-suite))
 149     newtest))