/usr/share/common-lisp/source/xlunit/tcase.lisp is in cl-xlunit 0.6.3-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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)
|