From 95c39c23a9d9db5b42fbc784ac75557fb1eb1a60 Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Mon, 4 Aug 2003 06:00:01 +0000
Subject: [PATCH] r5445: *** empty log message ***

---
 example.lisp | 108 +++++++++++++++++++
 package.lisp |  45 ++++++++
 src.lisp     | 300 +++++++++++++++++++++++++++++++++++++++++++++++++++
 tests.lisp   |  22 ++++
 xltest.asd   |  39 +++++++
 5 files changed, 514 insertions(+)
 create mode 100644 example.lisp
 create mode 100644 package.lisp
 create mode 100644 src.lisp
 create mode 100644 tests.lisp
 create mode 100644 xltest.asd

diff --git a/example.lisp b/example.lisp
new file mode 100644
index 0000000..4f1fcb9
--- /dev/null
+++ b/example.lisp
@@ -0,0 +1,108 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:        example.lisp
+;;;; Purpose:     Example file for XLTest
+;;;; Authors:     Kevin Rosenberg and Craig Brozefsky
+;;;;
+;;;; Put in public domain by Kevin Rosenberg and onShore, Inc
+;;;; $Id: example.lisp,v 1.1 2003/08/04 06:00:01 kevin Exp $
+;;;; *************************************************************************
+
+(defpackage #:xltest-example
+  (:use #:cl #:xltest)
+  (:export
+   #:math-test-suite))
+
+(in-package #:xltest-example)
+
+;;; First we define some basic fixtures that we are going to need to
+;;; perform our tests.  A fixture is a place to hold data we need
+;;; during testing.  Often there are many test cases that use the same
+;;; data.  Each of these test cases is an instance of a test-fixture.
+
+(def-test-fixture math-fixture ()
+  ((numbera
+    :accessor numbera)
+   (numberb
+    :accessor numberb))
+  (:documentation "Test fixture for math testing"))
+
+;;; Then we define a setup method for the fixture.  This method is run
+;;; prior to perfoming any test with an instance of this fixture.  It
+;;; should perform all initialization needed, and assume that it is starting
+;;; with a pristine environment, well to a point, use your head here.
+
+(defmethod setup ((fix math-fixture))
+  (setf (numbera fix) 2)
+  (setf (numberb fix) 3))
+
+;;; Then we define a teardown method, which should return the instance
+;;; to it's original form and reset the environment.  In this case
+;;; there is little for us to do since the fixture is quite static.
+;;; In other cases we may need to clear some database tables, or
+;;; otherwise get rid of state built up while perofmring the test.
+;;; Here we just return T.
+
+(defmethod teardown ((fix math-fixture))
+  t)
+
+;;; Once we hav a fixture we can start defining method on it which
+;;; will perform tests.  These methods should take one argument, an
+;;; instance of the fixture.  The method performs some operation and
+;;; then performs some tests to determine if the proper behavior
+;;; occured.  If there is a failure to behave as excpeted the method
+;;; raises a test-failure object by calling the method FAILURE.  This
+;;; is much like calling ERROR in that it stops processing that
+;;; method.  Each method should only check for one aspect of behavior.
+;;; This way triggering one failure would not result in another
+;;; behavior check from being skipped.  It does not matter what these
+;;; methods return
+
+(defmethod test-addition ((test math-fixture))
+  (let ((result (+ (numbera test) (numberb test))))
+    (test-assert (= result 5))))
+
+(defmethod test-subtraction ((test math-fixture))
+  (let ((result (- (numberb test) (numbera test))))
+    (assert-equal result 1)))
+
+;;; This method is meant to signal a failure
+(defmethod test-subtraction-2 ((test math-fixture))
+  (let ((result (- (numbera test) (numberb test))))
+    (assert-equal result 1)))
+
+
+;;; Now we can create a test-suite.  A test-suite contains a group of
+;;; test-cases (instances of test-fixture) and/or other test-suites.
+;;; We can specify which tests are in a test-suite when we define the
+;;; test-suite, or we can add them later.  See the documentation and
+;;; argument list for make-test-case for details on how to specify a
+;;; test-case.
+
+(defparameter *manual-math-test-suite*
+    (make-test-suite
+     "Math Test Suite"
+     "Simple test suite for arithmetic operators."
+     '(("Addition Test" math-fixture
+			:test-thunk test-addition
+			:description "A simple test of the + operator")
+       ("Subtraction Test" math-fixture
+	:test-thunk test-subtraction
+	:description "A simple test of the - operator"))))
+
+(add-test (make-test-case "Subtraction Test 2" 'math-fixture
+			  :test-thunk 'test-subtraction-2
+			  :description "A broken substraction test, should fail.")
+	  *manual-math-test-suite*)
+
+
+(defparameter *dynamic-math-test-suite* (make-test-suite 'math-fixture))
+
+;;;; Finally we can run our test suite and see how it performs.
+(report-result (run-test *manual-math-test-suite*
+			 :handle-errors t) :verbose t)
+
+(report-result (run-test *dynamic-math-test-suite*
+			 :handle-errors t) :verbose nil)
diff --git a/package.lisp b/package.lisp
new file mode 100644
index 0000000..049793c
--- /dev/null
+++ b/package.lisp
@@ -0,0 +1,45 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:        package.lisp
+;;;; Purpose:     Package definition for XLTEST
+;;;; Authors:     Kevin Rosenberg and Craig Brozefsky
+;;;;
+;;;; Put in public domain by Kevin Rosenberg and onShore, Inc
+;;;; $Id: package.lisp,v 1.1 2003/08/04 06:00:01 kevin Exp $
+;;;; *************************************************************************
+
+(in-package #:cl-user)
+
+(defpackage #:xltest-framework
+  (:use #:common-lisp)
+  (:nicknames #:xltest #: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
+   #:make-test-suite-for-fixture
+   #:assert-equal
+   #:assert-true
+   #:assert-false
+   #:test-assert
+   )
+  (:documentation "This is the XP TestSuite Framework."))
+
+(in-package #:xltest)
diff --git a/src.lisp b/src.lisp
new file mode 100644
index 0000000..20c3f1f
--- /dev/null
+++ b/src.lisp
@@ -0,0 +1,300 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:        src.lisp
+;;;; Purpose:     eXtreme Lisp Test Suite
+;;;; Authors:     Kevin Rosenberg and Craig Brozefsky
+;;;;
+;;;; Put in public domain by Kevin Rosenberg and onShore, Inc
+;;;; $Id: src.lisp,v 1.1 2003/08/04 06:00:01 kevin Exp $
+;;;; *************************************************************************
+
+(in-package #:xltest)
+
+
+(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
+	  :format-control format-str
+	  :format-arguments args))
+
+(defmacro test-assert (test)
+  `(unless ,test
+    (failure "Test assertion failed: ~s" ',test)))
+
+(defun assert-equal (v1 v2)
+  (unless (equal v1 v2)
+    (failure "Test equals failed: ~s ~s" v1 v2)))
+
+(defun assert-true (v)
+  (unless v
+    (failure "Test true failed: ~s" v)))
+
+(defun assert-false (v)
+  (when v
+    (failure "Test false failed")))
+
+
+(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 ((failures ())
+	(errs ()))
+    (unwind-protect-if handle-errors
+	(handler-case-if handle-errors
+	 (let ((res (progn (setup test)
+			   (funcall (test-thunk test) 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
+		   :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))
+
+(defun make-test-case (name fixture &key
+				    (test-thunk 'perform-test)
+				    (test-suite nil)
+				    (description nil))
+  "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 (make-instance fixture
+		   :test-name name
+		   :test-thunk 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)))
+
+(defun make-test-suite (name-or-fixture &optional description testspecs)
+  "Returns a new test-suite based on a name and TESTSPECS or a fixture
+instance"
+  (etypecase name-or-fixture
+    (symbol
+     (make-test-suite-for-fixture (make-instance name-or-fixture)))
+    (string
+     (let ((suite (make-instance 'test-suite :name name-or-fixture
+				 :description description)))
+       (dolist (testspec testspecs)
+	 (add-test (apply #'make-test-case testspec) suite))
+       suite))))
+
+(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))
+  (let ((start-time (get-internal-real-time)))
+    (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))
+      (make-instance 'suite-results 
+	:suite suite
+	:test-results res
+	:start-time start-time
+	:stop-time (get-internal-real-time)))))
+
+
+(defclass test-result ()
+  ((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"))
+
+(defclass suite-results ()
+  ((suite :initarg :suite :reader suite)
+   (start-time :initarg :start-time :reader start-time)
+   (stop-time :initarg :stop-time :reader stop-time)
+   (test-results :initarg :test-results :reader test-results))
+  (:documentation "Results of running a suite"))
+
+
+(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."
+  (when (or verbose (test-failures result) (test-errors result))
+    (when verbose
+      (format stream
+	      "------------------------------------------------------~%"))
+    (format stream "~A~A"
+	    (test-name (result-test result))
+	    (cond
+	     ((test-failures result) ":")
+	     ((test-errors result) ":")
+	     (t ": Passed")))
+    (when (test-failures result)
+      (format stream " Failures: ~{~A~^; ~}" (test-failures result)))
+    (when (test-errors result)
+      (format stream " Errors: ~{~A~^; ~}" (test-errors result)))
+    (fresh-line stream)
+    (when verbose
+      (when (description (result-test result))
+	(format stream "Description: ~A~%" 
+		(description (result-test result)))))))
+  
+(defmethod report-result ((results suite-results) &key (stream t)
+						       (verbose nil))
+  (format stream "~&.............~%")
+  (format stream "~&Time: ~D~%" 
+	  (float
+	   (/ (- (stop-time results) (start-time results))
+	      internal-time-units-per-second)))
+  (if (some (lambda (res) (or (test-failures res) (test-errors res)))
+	    (test-results results))
+      (dolist (foo (test-results results))
+	(report-result foo :stream stream :verbose verbose))
+    (format stream "~&OK (~D tests)~%" (length (test-results results)))))
+
+
+;;; Dynamic test suite addition by Kevin Rosenberg 8/2003
+
+(defun make-test-suite-for-fixture 
+    (fixture &key
+	     (name 
+	      (format nil "Automatic for ~A"
+		      (if (slot-boundp fixture 'test-name) 
+			  (test-name fixture)
+			(type-of fixture))))
+	     description)
+  (let ((suite  (make-instance 'test-suite
+		  :name name
+		  :description description))
+	(fns (find-test-generic-functions fixture)))
+    (dolist (fn fns)
+      (make-test-case fn (class-name (class-of fixture))
+		      :test-thunk fn
+		      :test-suite suite))
+    suite))
+
+(defun find-test-generic-functions (instance)
+  "Return a list of symbols for generic functions specialized on the
+class of an instance and whose name begins with the string 'test-'.
+This is used to dynamically generate a list of tests for a fixture."
+  (let ((res)
+	(package (symbol-package (class-name (class-of instance)))))
+    (do-symbols (s package)
+      (multiple-value-bind (sym status)
+	  (find-symbol (symbol-name s) package)
+	(when (and (or (eq status :external)
+		       (eq status :internal))
+		   (fboundp sym)
+		   (eq (symbol-package sym) package)
+		   (> (length (symbol-name sym)) 5)
+		   (string-equal "test-" (subseq (symbol-name sym) 0 5))
+		   (typep (symbol-function sym) 'generic-function)
+		   (plusp 
+		    (length 
+		     (compute-applicable-methods 
+		      (ensure-generic-function sym)
+		      (list instance)))))
+	  (push sym res))))
+    (nreverse res)))
+
+
+
diff --git a/tests.lisp b/tests.lisp
new file mode 100644
index 0000000..9f2302a
--- /dev/null
+++ b/tests.lisp
@@ -0,0 +1,22 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:        tests.lisp
+;;;; Purpose:     Test suite for XLTest
+;;;; Author:     Kevin Rosenberg
+;;;;
+;;;; Put in public domain by Kevin Rosenberg
+;;;; $Id: tests.lisp,v 1.1 2003/08/04 06:00:01 kevin Exp $
+;;;; *************************************************************************
+
+(defpackage #:xltest-tests
+  (:use #:cl #:xltest))
+
+(in-package #:xltest-tests)
+
+(defclass xltests (test-fixture)
+  ()
+  )
+
+(defmethod xltes
diff --git a/xltest.asd b/xltest.asd
new file mode 100644
index 0000000..7cbf663
--- /dev/null
+++ b/xltest.asd
@@ -0,0 +1,39 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          xltest.asd
+;;;; Purpose:       ASDF definition file for XLtest
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Aug 2003
+;;;;
+;;;; $Id: xltest.asd,v 1.1 2003/08/04 06:00:01 kevin Exp $
+;;;; *************************************************************************
+
+(defpackage #:xltest-system (:use #:asdf #:cl))
+(in-package #:xltest-system)
+
+(defsystem xltest
+  :name "xltest"
+  :author "Kevin Rosenberg based on work by Craig Brozensky"
+  :maintainer "Kevin M. Rosenberg <kmr@debian.org>"
+  :licence "Public domain"
+  :description "Extreme Lisp Testing Suite"
+  :long-description "The XLTEST package is toolkit for building test suites based on the XPTEST package by Craig Brozensky."
+  
+  :components
+  ((:file "package")
+   (:file "src" :depends-on ("package"))))
+
+(defmethod perform ((o test-op) (c (eql (find-system 'xltest))))
+  (oos 'load-op 'xltest-tests)
+  (oos 'test-op 'xltest-tests))
+
+(defsystem xltest-tests
+  :depends-on (xltest-tests)
+  :components ((:file "tests")))
+
+(defmethod perform ((o test-op) (c (eql (find-system 'xltest-tests))))
+  (or (funcall (intern (symbol-name #:do-tests)
+		       (find-package #:xltest-tests)))
+      (error "test-op failed")))
-- 
2.34.1