/usr/share/common-lisp/source/xlunit/fixture.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 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 | ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; ID: $Id$
;;;; Purpose: Test fixtures for XLUnit
;;;;
;;;; *************************************************************************
(in-package #:xlunit)
(defclass test-fixture ()
((test-fn
:initarg :test-fn :reader test-fn :initform nil
:documentation
"A function designator which will be applied to this instance
to perform that test-case.")
(test-name
:initarg :test-name :reader test-name
:documentation
"The name of this test-case, used in reports.")
(test-description
:initarg :description :reader description
:documentation
"Short description of this test-case, uses in reports"))
(:documentation
"Base class for test-fixtures. Test-cases are instances of test-fixtures."))
(defgeneric setup (test)
(:documentation
"Method called before performing a test, should set up the
environment the test-case needs to operate in."))
(defmethod setup ((test test-fixture))
t)
(defgeneric teardown (test)
(:documentation
"Method called after performing a test. Should reverse everything
that the setup method did for this instance."))
(defmethod teardown ((test test-fixture))
t)
(defmacro handler-case-if (test form &body cases)
`(if ,test
(handler-case
,form
,@cases)
,form))
(defmacro unwind-protect-if (test protected cleanup)
`(if ,test
(unwind-protect
,protected
,cleanup)
(progn ,protected ,cleanup)))
(defmethod run-test ((test test-fixture)
&key (result (make-instance 'test-result))
(handle-errors t))
"Perform the test represented by the given test-case or test-suite.
Returns a test-result object."
(incf (test-count result))
(with-slots (failures errors) result
(unwind-protect-if handle-errors
(handler-case-if handle-errors
(let ((res (progn (setup test)
(funcall (test-fn test) test))))
(when (typep res 'test-failure-condition)
(push (make-test-failure test res) failures)))
(test-failure-condition (failure)
(push (make-test-failure test failure) failures))
(error (err)
(push (make-test-failure test err) errors)))
(if handle-errors
(handler-case
(teardown test)
(error (err)
(push (make-test-failure test err) errors)))
(teardown test))))
result)
(defun make-test (fixture name &key test-fn test-suite description)
"Create a test-case which is an instance of FIXTURE. TEST-FN is
the method that will be invoked when perfoming this test, and can be a
symbol or a lambda taking a single argument, the test-fixture
instance. DESCRIPTION is obviously what it says it is."
(let ((newtest (make-instance fixture
:test-name (etypecase name
(symbol
(string-downcase (symbol-name name)))
(string
name))
:test-fn
(if(and (symbolp name) (null test-fn))
name
test-fn)
:description description)))
(when test-suite (add-test newtest test-suite))
newtest))
|