tcase.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; ID:      $Id: tcase.lisp,v 1.5 2003/08/06 14:51:01 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 :initform ""
  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) &key (handle-errors t))
  60   "Generalized to work on test-case and test-suites"
  61   (let ((res (make-test-results)))
  62     (run-on-test-results ob res :handle-errors handle-errors)
  63     res))
  64
  65 (defmethod run-on-test-results ((test test-case) result
  66                                 &key (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   (values))
  77
  78 (defmethod run-test ((test test-case))
  79     (funcall (method-body test)))
  80
  81 (defmethod run-protected ((test test-case) res
  82                           &key (handle-errors t) test-condition)
  83   (if handle-errors
  84       (handler-case
  85           (run-base test)
  86         (assertion-failed (condition)
  87           (add-failure res test condition))
  88         (t (condition)
  89           (when (and test-condition
  90                      (not (typep condition test-condition)))
  91             (add-failure res test
  92                          (make-instance 'assertion-failed
  93                            :format-control
  94                            "Assert condition ~A, but condition ~A signaled"
  95                            :format-arguments
  96                            (list test-condition condition)))))
  97         (serious-condition (condition)
  98           (add-error res test condition))
  99         (:no-error ()
 100           (when test-condition
 101             (add-failure res test
 102                          (make-instance 'assertion-failed
 103                            :format-control "Assert condition ~A, but no condition signaled"
 104                            :format-arguments (list test-condition))))))
 105     (run-base test))
 106   res)