This file is indexed.

/usr/share/common-lisp/source/xptest/xptestsuite.lisp is in cl-xptest 1.2.4-3.

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
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
;;; -*- Mode: Lisp -*-
;;;; xptestsuite.lisp --- Test suite based on Extreme Programming
;;;;                      Framework by Kent Beck
;;;;
;;;; Inspired by http://www.xprogramming.com/testfram.htm
;;;;
;;;; Author: Craig Brozefsky <craig@onshore.com>
;;;; Put in public domain by onShore, Inc
;;;;
;;;; $Id$

(in-package #:cl-user)

(defpackage #:xp-test-framework
  (:use #:common-lisp)
  (:nicknames #:xp-test #:xptest)
  (:export
     ;;; Framework classes
   #:setup
   #:teardown
   #:perform-test
   #:test-failure
   #:failure
   #:run-test
   #:def-test-fixture
   #:make-test-case
   #:make-test-suite
   #:setup-testsuite-named
   #:teardown-testsuite-named
   #:add-test
   #:test-named
   #:remove-test
   #:tests
   #:test-result
   #:report-result
   )
  (:documentation "This is the XP TestSuite Framework."))

(in-package :xp-test)

(defclass test-fixture ()
  ((test-thunk
    :initarg :test-thunk
    :reader test-thunk
    :initform 'perform-test
    :documentation
    "A thunk or symbol which will be applied to this instance, a
test-case, to perform that test-case. Defaults to 'perform-test")
   (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."))

(defmethod setup ((test test-fixture))
  "Method called before performing a test, should set up the
environment the test-case needs to operate in."
  t)

(defmethod teardown ((test test-fixture))
  "Method called after performing a test.  Should reverse everything that the
setup method did for this instance."
  t)

(define-condition test-failure (simple-condition) ()
  (:documentation "Base class for all test failures."))

(defun failure (format-str &rest args)
  "Signal a test failure and exit the test."
  (signal 'test-failure
          #+(or cmu allegro openmcl) :format-control
          #-(or cmu allegro openmcl) :format-string
          format-str
          :format-arguments args))

(defmacro test-assert (test)
  `(unless ,test
    (failure "Test assertion failed: ~s" ',test)))


(defmethod perform-test ((test test-fixture))
  "Default method for performing tests upon a 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 (handle-errors t))
  "Perform the test represented by the given test-case or test-suite.
Returns one or more test-result objects, one for each test-case
performed."
  (let ((start-time (get-universal-time))
        (failures ())
        (errs ()))
    (unwind-protect-if handle-errors
        (handler-case-if handle-errors
         (let ((res (progn (setup test)
                           (apply (test-thunk test) (list test)))))
           (if (typep res 'test-failure)
               (setf failures (cons res failures))))
         (test-failure (failure)
                       (setf failures (cons failure failures)))
         (t (err)
            (setf errs (cons err errs))))
      (handler-case-if handle-errors
       (teardown test)
       (t (err)
          (setf errs (cons err errs)))))
    (make-instance 'test-result
                   :test test
                   :start-time start-time
                   :stop-time (get-universal-time)
                   :failures failures
                   :errors errs)))

(defmacro def-test-fixture (name supers slotdefs &rest class-options)
  "Define a new test-fixture class.  Works just like defclass, but
ensure that test-fixture is a super."
  `(defclass ,name ,(append supers (list 'test-fixture))
     ,slotdefs ,@class-options))

(defmacro make-test-case (name fixture &key
                               (test-thunk 'perform-test)
                               (test-suite nil)
                               (description "No description."))
  "Create a test-case which is an instance of FIXTURE.  TEST-THUNK 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 (gensym "new-test")))
    `(let ((,newtest (make-instance ,fixture
                                    :test-name ,name
                                    :test-thunk ,(if (eq test-thunk 'perform-test)
                                                     ''perform-test
                                                   test-thunk)
                                    :description ,description)))
       (if ,test-suite (add-test ,newtest ,test-suite))
       ,newtest)))

(defclass test-suite ()
  ((name
    :initarg :name
    :reader test-suite-name)
   (tests
    :initarg :tests
    :accessor tests-hash
    :initform (make-hash-table :test 'equal))
   (description
    :initarg :description
    :reader description
    :initform "No description.")))

(defmethod tests ((suite test-suite))
  (let ((tlist nil))
    (maphash #'(lambda (k v)
                 (declare (ignore k))
                 (setf tlist (cons v tlist)))
             (tests-hash suite))
    (reverse tlist)))

(defmacro make-test-suite (name description &rest testspecs)
  "Returns a new test-suite.  TESTSPECS are just like lists of
arguments to MAKE-TEST-CASE."
  (let* ((newsuite (gensym "test-suite"))
         (testforms (mapcar #'(lambda (spec)
                                (list
                                 'add-test
                                 (cons 'make-test-case spec)
                                 newsuite))
                            testspecs)))
    `(let ((,newsuite (make-instance 'test-suite :name ,name
                                     :description ,description)))
       ,@testforms
       ,newsuite)))

(defmethod add-test ((test test-fixture) (suite test-suite))
  (setf (gethash (test-name test) (tests-hash suite)) test))

(defmethod add-test ((test test-suite) (suite test-suite))
  (setf (gethash (test-suite-name test) (tests-hash suite)) test))

(defmethod remove-test ((test test-fixture) (suite test-suite))
  (remhash (test-name test) (tests-hash suite)))

(defmethod remove-test ((test test-suite) (suite test-suite))
  (remhash (test-suite-name test) (tests-hash suite)))

(defmethod test-named ((name string) (suite test-suite))
  (gethash name (tests-hash suite)))

(defmethod setup-testsuite-named (name)
  (declare (ignore name))
  t)

(defmethod teardown-testsuite-named (name)
  (declare (ignore name))
  t)

(defmethod run-test ((suite test-suite) &key (handle-errors t))
  (setup-testsuite-named (slot-value suite 'name))
  (let ((res (mapcar (lambda (test) (run-test test
                                              :handle-errors handle-errors))
                     (tests suite))))
    (teardown-testsuite-named (slot-value suite 'name))
    res))


(defclass test-result ()
  ((start-time
    :initarg :start-time
    :reader start-time)
   (stop-time
    :initarg :stop-time
    :reader stop-time)
   (test
    :initarg :test
    :reader result-test)
   (failures
    :initarg :failures
    :reader test-failures
    :initform nil)
   (errors
    :initarg :errors
    :reader test-errors
    :initform nil))
  (:documentation
   "The result of applying a test"))

(defmethod report-result ((result test-result) &key (stream t) (verbose nil))
  "Print out a test-result object for a report to STREAM, default to
standard-output.  If VERBOSE is non-nil then will produce a lengthy
and informative report, otherwise just prints wether the test passed
or failed or errored out."
  (if verbose (format stream
                      "------------------------------------------------------~%"))
  (format stream "Test ~A ~A ~%"
          (test-name (result-test result))
          (cond
           ((test-failures result) "Failed")
           ((test-errors result) "Errored")
           (t "Passed")))
  (if verbose
      (progn
        (format stream "Description: ~A~%" (description (result-test result)))
        (if (test-failures result)
            (progn
              (format stream "Failures:~%")
              (mapcar #'(lambda (fail) (format stream "    ~A" fail))
                      (test-failures result))))
        (if (test-errors result)
            (progn
              (format stream "Errors:~%")
              (mapcar #'(lambda (fail) (format stream "    ~A" fail))
                      (test-errors result))))))
  ;(format stream "~%~%") ; debian bug #190398
  )

(defmethod report-result ((results list) &key (stream t) (verbose nil))
  (dolist (foo results)
    (report-result foo :stream stream :verbose verbose)))