result.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; ID:      $Id: result.lisp,v 1.5 2003/08/04 16:42:27 kevin Exp $
   6 ;;;; Purpose:  Result functions for XLUnit
   7 ;;;;
   8 ;;;; *************************************************************************
   9
  10 (in-package #:xlunit)
  11
  12
  13 (defclass test-results ()
  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)"))
  21
  22 (defmethod failure-count ((res test-results))
  23   (length (failures res)))
  24
  25 (defmethod error-count ((res test-results))
  26   (length (errors res)))
  27
  28 (defun make-test-results ()
  29   (make-instance 'test-results))
  30
  31
  32 (defmethod start-test ((tcase test) (res test-results))
  33   (incf (run-tests res))
  34   (mapc (lambda (listener) (start-test listener tcase)) (listeners res))
  35   res)
  36
  37 (defmethod end-test ((tcase test) (res test-results))
  38   (incf (run-tests res))
  39   (mapc (lambda (listener) (end-test listener tcase)) (listeners res))
  40   res)
  41
  42 (defmethod add-listener ((res test-results) (listener test-listener))
  43   (push listener (listeners res)))
  44
  45
  46 ;; Test Failures
  47
  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-results slots"))
  53
  54 (defun make-test-failure (test condition)
  55   (make-instance 'test-failure :failed-test test
  56                  :thrown-condition condition))
  57
  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))
  61
  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)))))
  68
  69 (defmethod was-successful ((result test-results))
  70   "Returns T if a result has no failures or errors"
  71   (and (null (failures result)) (null (errors result))))
  72
  73
  74 ;----------------------------------------------------------------------
  75 ; methods  add-error, add-failure
  76 ;----------------------------------------------------------------------
  77
  78 (defmethod add-error ((ob test-results) (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))
  82           (listeners ob)))
  83
  84
  85 (defmethod add-failure ((ob test-results) (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))
  89         (listeners ob)))
  90