;;;; Author: Craig Brozefsky <craig@onshore.com>
;;;; Put in public domain by onShore, Inc
;;;;
-;;;; $Id: xptestsuite.lisp,v 1.1 2002/10/22 18:46:20 kevin Exp $
+;;;; $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)
(defun failure (format-str &rest args)
"Signal a test failure and exit the test."
(signal 'test-failure
- #+(or cmu allegro) :format-control
- #-(or cmu allegro) :format-string
- format-str
- :format-arguments args))
+ #+(or cmu allegro openmcl) :format-control
+ #-(or cmu allegro openmcl) :format-string
+ format-str
+ :format-arguments args))
(defmacro test-assert (test)
`(unless ,test
`(if ,test
(handler-case
,form
- ,@cases)
+ ,@cases)
,form))
(defmacro unwind-protect-if (test protected cleanup)
`(if ,test
(unwind-protect
- ,protected
- ,cleanup)
+ ,protected
+ ,cleanup)
(progn ,protected ,cleanup)))
(defmethod run-test ((test test-fixture) &key (handle-errors t))
Returns one or more test-result objects, one for each test-case
performed."
(let ((start-time (get-universal-time))
- (failures ())
- (errs ()))
+ (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
+ (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)))))
+ (setf errs (cons err errs)))))
(make-instance 'test-result
- :test test
- :start-time start-time
- :stop-time (get-universal-time)
- :failures failures
- :errors errs)))
+ :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
,slotdefs ,@class-options))
(defmacro make-test-case (name fixture &key
- (test-thunk 'perform-test)
- (test-suite nil)
- (description "No description."))
+ (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)))
+ :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
(defmethod tests ((suite test-suite))
(let ((tlist nil))
(maphash #'(lambda (k v)
- (declare (ignore k))
- (setf tlist (cons v tlist)))
- (tests-hash suite))
+ (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)))
+ (testforms (mapcar #'(lambda (spec)
+ (list
+ 'add-test
+ (cons 'make-test-case spec)
+ newsuite))
+ testspecs)))
`(let ((,newsuite (make-instance 'test-suite :name ,name
- :description ,description)))
+ :description ,description)))
,@testforms
,newsuite)))
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")))
+ (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 "~%~%"))
+ (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)