cl-xptest-1.2.4/0000755000175000017500000000000011235174643012461 5ustar kevinkevincl-xptest-1.2.4/COPYING0000644000175000017500000000042311235173550013507 0ustar kevinkevinThis code has been put into the public domain by onShore Development Inc, and it's primary author Craig Brozefsky. However, we would appreciate it if improvements and modifications were contributed back to the project so that everyone can share in them. cl-xptest-1.2.4/README0000644000175000017500000000217411235173634013344 0ustar kevinkevinxptest - An "Extreme Programming" test framework for Common Lisp ====================================================================== xptest is a framework for building test cases, managing test data, and putting these together into test suites. It provides a minimal level of support for reports on test runs. It's also a nice development tool in that one can easily use it for organizing code fragments when developing more complex features. License (well, non-License) ====================================================================== xptest is in the public domain. It's so simple that even a copyright is just a pathetic clinging some romantic notion of the author. Installation ====================================================================== This package uses ASDF to load its files. Author ====================================================================== xptest is maintained by Craig Brozefsky . Any bug reports, comments, or patches can be sent to him. Others who have contributed: Lyn Headley Stig Erik Sandoe Kevin Rosenberg cl-xptest-1.2.4/xptest-example.lisp0000644000175000017500000001026510667175536016350 0ustar kevinkevin;;; -*- Mode: Lisp -*- ;;;; xptest-eaxmple.lisp --- Example of test suite based on Extreme ;;;; Programming Framework by Kent Beck ;;;; ;;;; Author: Craig Brozefsky ;;;; Put in public domain by onShore, Inc (defpackage #:xp-test-example (:use #:common-lisp #:xp-test) (:export #:math-test-suite)) (in-package #:xp-test-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 addition-test ((test math-fixture)) (let ((result (+ (numbera test) (numberb test)))) (unless (= result 5) (failure "Result was not 5 when adding ~A and ~A" (numbera test) (numberb test))))) (defmethod subtraction-test ((test math-fixture)) (let ((result (- (numberb test) (numbera test)))) (unless (= result 1) (failure "Result was not 1 when subtracting ~A ~A" (numberb test) (numbera test))))) ;;; This method is meant to signal a failure (defmethod subtraction-test2 ((test math-fixture)) (let ((result (- (numbera test) (numberb test)))) (unless (= result 1) (failure "Result was not 1 when subtracting ~A ~A" (numbera test) (numberb test))))) ;;; 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. (setf math-test-suite (make-test-suite "Math Test Suite" "Simple test suite for arithmetic operators." ("Addition Test" 'math-fixture :test-thunk 'addition-test :description "A simple test of the + operator") ("Subtraction Test" 'math-fixture :test-thunk 'subtraction-test :description "A simple test of the - operator"))) (add-test (make-test-case "Substraction Test 2" 'math-fixture :test-thunk 'subtraction-test2 :description "A broken substraction test, should fail.") math-test-suite) ;;;; Finally we can run our test suite and see how it performs. ;;;; (report-result (run-test math-test-suite) :verbose t) cl-xptest-1.2.4/xptest.asd0000644000175000017500000000170110667175536014512 0ustar kevinkevin;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: xptest.asd ;;;; Purpose: ASDF definition file for Xptest ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Sep 2002 ;;;; ;;;; $Id$ ;;;; ************************************************************************* (defpackage #:xptest-system (:use #:asdf #:cl)) (in-package #:xptest-system) (defsystem :xptest :name "cl-xptest" :author "Craig Brozensky" :version "2003.04.21" :maintainer "Kevin M. Rosenberg " :licence "Public domain" :description "Extreme Programming Testing Suite" :long-description "The XPTEST package is toolkit for building test suites, very much inspired by the test frameworks that the Extreme Programming crew made available for Smalltalk an other languages." :components ((:file "xptestsuite"))) cl-xptest-1.2.4/xptestsuite.lisp0000644000175000017500000002150210667175536015765 0ustar kevinkevin;;; -*- 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 ;;;; 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)))