tcase.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; ID:      $Id: tcase.lisp,v 1.4 2003/08/05 22:56:25 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
  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   (if handle-errors
  82       (handler-case
  83           (run-base test)
  84         (assertion-failed (condition)
  85           (add-failure res test condition))
  86         (serious-condition (condition)
  87           (add-error res test condition)))
  88       (run-base test))
  89   res)