File: tcase.lisp

package info (click to toggle)
cl-xlunit 0.6.3-2
  • links: PTS, VCS
  • area: main
  • in suites: jessie, jessie-kfreebsd, squeeze, stretch, wheezy
  • size: 92 kB
  • ctags: 110
  • sloc: lisp: 573; makefile: 39
file content (89 lines) | stat: -rw-r--r-- 2,900 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; ID:      $Id$
;;;; Purpose: Test fixtures for XLUnit
;;;;
;;;; *************************************************************************

(in-package #:xlunit)


(defclass test ()
  ())

(defclass test-case (test)
  ((existing-suites :initform nil :accessor existing-suites
                    :allocation :class)
   (method-body
    :initarg :method-body :accessor method-body :initform nil
    :documentation
    "A function designator which will be applied to this instance
to perform that test-case.")
   (name :initarg :name :reader name :initform ""
         :documentation "The name of this test-case, used in reports.")
   (description :initarg :description :reader description
                :documentation
                "Short description of this test-case, uses in reports")
   (suite :initform nil :accessor suite :initarg :suite))
  (:documentation
   "Base class for test-cases."))

(defmethod initialize-instance :after ((ob test-case) &rest initargs)
  (declare (ignore initargs))
  (if (null (existing-suites ob))
    (setf (existing-suites ob) (make-hash-table)))  ;;hash singleton
  (unless (gethash (type-of ob) (existing-suites ob))
    (setf (gethash (type-of ob) (existing-suites ob))
          (make-instance 'test-suite)))             ;;specifi suite singleton
  (setf (suite ob) (gethash (type-of ob) (existing-suites ob))))


(defgeneric set-up (test)
  (:documentation
   "Method called before performing a test, should set up the
environment the test-case needs to operate in."))

(defmethod set-up ((test test-case))
  )

(defgeneric tear-down (test)
  (:documentation
   "Method called after performing a test.  Should reverse everything
that the setup method did for this instance."))

(defmethod tear-down ((test test-case))
  )

(defmethod run ((ob test) &key (handle-errors t))
  "Generalized to work on test-case and test-suites"
  (let ((res (make-test-results)))
    (run-on-test-results ob res :handle-errors handle-errors)
    res))

(defmethod run-on-test-results ((test test-case) result
                                &key (handle-errors t))
  (start-test test result)
  (run-protected test result :handle-errors handle-errors)
  (end-test test result))

(defmethod run-base ((test test-case))
  (set-up test)
  (unwind-protect
      (run-test test)
    (tear-down test)))

(defmethod run-test ((test test-case))
    (funcall (method-body test)))

(defmethod run-protected ((test test-case) res &key (handle-errors t))
  (if handle-errors
      (handler-case
          (run-base test)
        (assertion-failed (condition)
          (add-failure res test condition))
        (serious-condition (condition)
          (add-error res test condition)))
      (run-base test))
  res)