1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; ID: $Id: result.lisp,v 1.4 2003/08/04 16:13:58 kevin Exp $
6 ;;;; Purpose: Result functions for XLUnit
8 ;;;; *************************************************************************
13 (defclass test-result ()
14 ((test :initarg :test :reader result-test)
15 (count :initform 0 :accessor run-tests)
16 (failures :initarg :failures :accessor failures :initform nil)
17 (errors :initarg :errors :accessor errors :initform nil)
18 (listeners :initform nil :accessor listeners)
19 (stop :initform nil :accessor stop))
20 (:documentation "Results of running test(s)"))
22 (defmethod failure-count ((res test-result))
23 (length (failures res)))
25 (defmethod error-count ((res test-result))
26 (length (errors res)))
28 (defun make-test-result ()
29 (make-instance 'test-result))
32 (defmethod start-test ((tcase test) (res test-result))
33 (incf (run-tests res))
34 (mapc (lambda (listener) (start-test listener tcase)) (listeners res))
37 (defmethod end-test ((tcase test) (res test-result))
38 (incf (run-tests res))
39 (mapc (lambda (listener) (end-test listener tcase)) (listeners res))
42 (defmethod add-listener ((res test-result) (listener test-listener))
43 (push listener (listeners res)))
48 (defclass test-failure ()
49 ((failed-test :initarg :failed-test :reader failed-test)
50 (thrown-condition :initarg :thrown-condition
51 :reader thrown-condition))
52 (:documentation "Stored failures/errors in test-result slots"))
54 (defun make-test-failure (test condition)
55 (make-instance 'test-failure :failed-test test
56 :thrown-condition condition))
58 (defmethod is-failure ((failure test-failure))
59 "Returns T if a failure was a test-failure condition"
60 (typep (thrown-condition failure) 'test-failure-condition))
62 (defmethod print-object ((obj test-failure) stream)
63 (print-unreadable-object (obj stream :type t :identity nil)
64 (format stream "~A: " (failed-test obj))
65 (apply #'format stream
66 (simple-condition-format-control (thrown-condition obj))
67 (simple-condition-format-arguments (thrown-condition obj)))))
69 (defmethod was-successful ((result test-result))
70 "Returns T if a result has no failures or errors"
71 (and (null (failures result)) (null (errors result))))
74 ;----------------------------------------------------------------------
75 ; methods add-error, add-failure
76 ;----------------------------------------------------------------------
78 (defmethod add-error ((ob test-result) (tcase test-case) condition)
79 (push (make-test-failure tcase condition) (errors ob))
80 (mapc #'(lambda (single-listener)
81 (add-error single-listener tcase condition))
85 (defmethod add-failure ((ob test-result) (tcase test-case) condition)
86 (push (make-test-failure tcase condition) (failures ob))
87 (mapc #'(lambda (single-listener)
88 (add-failure single-listener tcase condition))