tcase.lisp

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