cl-xlunit-0.6.3/0000755000175000017500000000000011235173251012451 5ustar kevinkevincl-xlunit-0.6.3/LICENSE0000644000175000017500000000304210667175533013472 0ustar kevinkevinCopyright (c) 2003 Kevin M. Rosenberg Copyright (C) 2002 Canoo Engineering AG All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of the contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. cl-xlunit-0.6.3/Makefile0000644000175000017500000000021510667175533014124 0ustar kevinkevinall: .PHONY: clean clean: @rm -rf .bin @rm -f *.ufsl *.fsl *.fas *.x86f *.sparcf *.fasl* *.lib @rm -f *~ *.bak *.orig *.err \#*\# .#* cl-xlunit-0.6.3/README0000644000175000017500000000043711235172347013342 0ustar kevinkevinXLUnit provides a unit testing package for Common Lisp. It it based on the 3 similar packages: JUnit by Kent Beck XPTest package by OnShore development CLOS-unit by Sandro Pedrazzini XLUnit comes with its own test suite (tests.lisp) along with an example file (example.lisp). cl-xlunit-0.6.3/assert.lisp0000644000175000017500000000517710667175533014672 0ustar kevinkevin;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; ID: $Id$ ;;;; Purpose: Assert functions for XLUnit ;;;; ;;;; ************************************************************************* (in-package #:xlunit) (define-condition assertion-failed (simple-condition) ((message :initform nil :initarg :message :accessor message)) (:documentation "Base class for all test failures.")) (defmethod print-object ((obj assertion-failed) stream) (print-unreadable-object (obj stream :type t :identity nil) (apply #'format stream (simple-condition-format-control obj) (simple-condition-format-arguments obj)))) (defun failure-message (message &optional format-str &rest args) "Signal a test failure and exit the test." (signal 'assertion-failed :message message :format-control format-str :format-arguments args)) (defun failure (format-str &rest args) "Signal a test failure and exit the test." (apply #'failure-message nil format-str args)) (defun assert-equal (v1 v2 &optional message) (unless (equal v1 v2) (failure-message message "Assert equal: ~S ~S" v1 v2))) (defun assert-eql (v1 v2 &optional message) (unless (eql v1 v2) (failure-message message "Assert equal: ~S ~S" v1 v2))) (defun assert-not-eql (v1 v2 &optional message) (when (eql v1 v2) (failure-message message "Assert not eql: ~S ~S" v1 v2))) (defmacro assert-true (v &optional message) `(unless ,v (failure-message ,message "Assert true: ~S" ',v))) (defmacro assert-false (v &optional message) `(when ,v (failure-message ,message "Assert false: ~S" ',v))) (defmacro assert-condition (condition form &optional message) (let ((cond (gensym "COND-"))) `(handler-case (progn ,form (values)) (t (,cond) (when (and (typep ,cond 'serious-condition) (not (typep ,cond ,condition))) (failure-message ,message "Assert condition ~A, but signaled condition ~A" ,condition ,cond))) (:no-error () (failure-message ,message "Assert condition ~A, but no condition signaled" ,condition))))) (defmacro assert-not-condition (condition form &optional message) (let ((cond (gensym "COND-"))) `(handler-case (progn ,form (values)) (serious-condition (,cond) (unless (typep ,cond ,condition) (failure-message ,message "Assert not condition ~A" ,condition)))))) cl-xlunit-0.6.3/example.lisp0000644000175000017500000000353710667175533015022 0ustar kevinkevin;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; ID: $Id$ ;;;; Purpose: Example file for XLUnit ;;;; ;;;; ************************************************************************* (defpackage #:xlunit-example (:use #:cl #:xlunit) (:export #:math-test-suite)) (in-package #:xlunit-example) ;;; First we define some basic test-cases that we are going to need to ;;; perform our tests. A test-case 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-case. (defclass math-test-case (test-case) ((numbera :accessor numbera) (numberb :accessor numberb)) (:documentation "Test test-case for math testing")) ;;; Then we define a set-up method for the test-case. This method is run ;;; prior to perfoming any test with an instance of this test-case. 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 set-up ((tcase math-test-case)) (setf (numbera tcase) 2) (setf (numberb tcase) 3)) (def-test-method test-addition ((test math-test-case) :run nil) (let ((result (+ (numbera test) (numberb test)))) (assert-true (= result 5)))) (def-test-method test-subtraction ((test math-test-case) :run nil) (let ((result (- (numberb test) (numbera test)))) (assert-equal result 1))) ;;; This method is meant to signal a failure (def-test-method test-subtraction-2 ((test math-test-case) :run nil) (let ((result (- (numbera test) (numberb test)))) (assert-equal result 1 "This is meant to failure"))) ;;;; Finally we can run our test suite and see how it performs. (textui-test-run (get-suite math-test-case)) cl-xlunit-0.6.3/fixture.lisp0000644000175000017500000000663510667175533015057 0ustar kevinkevin;;;; -*- 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)) cl-xlunit-0.6.3/listener.lisp0000644000175000017500000000102510667175533015202 0ustar kevinkevin;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; ID: $Id$ ;;;; Purpose: Listener functions for XLUnit ;;;; ;;;; ************************************************************************* (in-package #:xlunit) (defclass test-listener () ()) (defmethod start-test ((obj test-listener) tcase) (declare (ignore tcase))) (defmethod end-test ((obj test-listener) tcase) (declare (ignore tcase))) cl-xlunit-0.6.3/package.lisp0000644000175000017500000000220310667175533014747 0ustar kevinkevin;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; ID: $Id$ ;;;; Purpose: Package definition for XLUnit ;;;; ;;;; $Id$ ;;;; ************************************************************************* (in-package #:cl-user) (defpackage #:xlunit (:use #:cl) (:export ;; test-case.lisp #:test-case #:def-test-method #:set-up #:tear-down #:run #:run-test #:make-test ;; assert #:assert-equal #:assert-eql #:assert-not-eql #:assert-true #:assert-false #:assert-condition #:test #:test-error #:test-no-error #:test-warning #:test-no-warning #:failure ;; suite.lisp #:textui-test-run #:make-test-suite #:setup-testsuite-named #:teardown-testsuite-named #:add-test #:named-test #:remove-test #:tests #:get-suite #:suite #:test-suite #:run-on-test-results ;; printer.lisp #:summary ;; result.lisp #:test-results #:make-test-results #:was-successful ) (:documentation "This is the XLUnit Framework.")) cl-xlunit-0.6.3/printer.lisp0000644000175000017500000000523110667175533015043 0ustar kevinkevin;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; ID: $Id$ ;;;; Purpose: Printer functions for XLUnit ;;;; ;;;; ************************************************************************* (in-package #:xlunit) ;---------------------------------------------------------------------- ; method print-results ;---------------------------------------------------------------------- (defmethod print-results ((obj textui-test-runner) result seconds) (print-header obj result seconds) (print-defects obj (errors result) "error") (print-defects obj (failures result) "failure") (print-footer obj result) (values)) (defmethod print-header ((obj textui-test-runner) result seconds) (declare (ignore result)) (format (ostream obj) "~&Time: ~D~%~%" (coerce seconds 'float))) (defmethod print-defects ((obj textui-test-runner) defects title) (when defects (let ((count (length defects))) (if (= 1 count) (format (ostream obj) "~%There was 1 ~A:~%" title) (format (ostream obj) "~%There were ~D ~A:~%" count title)) (dotimes (i count) (let* ((defect (nth i defects)) (condition (thrown-condition defect))) (format (ostream obj) "~A) ~A: " (1+ i) (name (failed-test defect))) (typecase condition (assertion-failed (apply #'format (ostream obj) (simple-condition-format-control condition) (simple-condition-format-arguments condition)) (format (ostream obj) "~%") (when (message condition) (let ((spaces (+ 2 (length (format nil "~D" count))))) (dotimes (i spaces) (write-char #\space (ostream obj)))) (format (ostream obj) "~A~%" (message condition)))) (t (format (ostream obj) "~A~%" condition)))))))) (defmethod print-footer ((obj textui-test-runner) result) (let ((failures (failures result)) (errors (errors result)) (run-tests (run-tests result))) (cond ((and (null failures) (null errors)) (format (ostream obj) "~%OK (~a tests)~%" run-tests)) (t (format (ostream obj) "~%~%FAILURES!!!~%") (format (ostream obj) "Run: ~a Failures: ~a Errors: ~a~%" run-tests (length failures) (length errors)))))) (defgeneric summary (result)) (defmethod summary ((result test-results)) (format nil "~D run, ~D erred, ~D failed" (run-tests result) (error-count result) (failure-count result))) cl-xlunit-0.6.3/result.lisp0000644000175000017500000000601510667175533014677 0ustar kevinkevin;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; ID: $Id$ ;;;; Purpose: Result functions for XLUnit ;;;; ;;;; ************************************************************************* (in-package #:xlunit) (defclass test-results () ((test :initarg :test :reader result-test) (count :initform 0 :accessor run-tests) (failures :initarg :failures :accessor failures :initform nil) (errors :initarg :errors :accessor errors :initform nil) (listeners :initform nil :accessor listeners) (stop :initform nil :accessor stop)) (:documentation "Results of running test(s)")) (defmethod failure-count ((res test-results)) (length (failures res))) (defmethod error-count ((res test-results)) (length (errors res))) (defun make-test-results () (make-instance 'test-results)) (defmethod start-test ((tcase test) (res test-results)) (incf (run-tests res)) (mapc (lambda (listener) (start-test listener tcase)) (listeners res)) res) (defmethod end-test ((tcase test) (res test-results)) (mapc (lambda (listener) (end-test listener tcase)) (listeners res)) res) (defmethod add-listener ((res test-results) (listener test-listener)) (push listener (listeners res))) ;; Test Failures (defclass test-failure () ((failed-test :initarg :failed-test :reader failed-test) (thrown-condition :initarg :thrown-condition :reader thrown-condition)) (:documentation "Stored failures/errors in test-results slots")) (defun make-test-failure (test condition) (make-instance 'test-failure :failed-test test :thrown-condition condition)) (defmethod is-failure ((failure test-failure)) "Returns T if a failure was a test-failure condition" (typep (thrown-condition failure) 'assertion-failed)) (defmethod print-object ((obj test-failure) stream) (print-unreadable-object (obj stream :type t :identity nil) (format stream "~A: " (failed-test obj)) (apply #'format stream (simple-condition-format-control (thrown-condition obj)) (simple-condition-format-arguments (thrown-condition obj))))) (defmethod was-successful ((result test-results)) "Returns T if a result has no failures or errors" (and (null (failures result)) (null (errors result)))) ;---------------------------------------------------------------------- ; methods add-error, add-failure ;---------------------------------------------------------------------- (defmethod add-error ((ob test-results) (tcase test-case) condition) (push (make-test-failure tcase condition) (errors ob)) (mapc #'(lambda (single-listener) (add-error single-listener tcase condition)) (listeners ob))) (defmethod add-failure ((ob test-results) (tcase test-case) condition) (push (make-test-failure tcase condition) (failures ob)) (mapc #'(lambda (single-listener) (add-failure single-listener tcase condition)) (listeners ob))) cl-xlunit-0.6.3/suite.lisp0000644000175000017500000000611110667175533014507 0ustar kevinkevin;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; ID: $Id$ ;;;; Purpose: Suite functions for XLUnit ;;;; ;;;; ************************************************************************* (in-package #:xlunit) (defclass test-suite (test) ((name :initform "" :initarg :name :reader test-suite-name) (tests :initarg :tests :accessor tests :initform nil) (description :initarg :description :reader description :initform "No description."))) (defmacro get-suite (class-name) `(suite (make-instance ',class-name))) (defmethod add-test ((ob test-suite) (new-test test)) (remove-test new-test ob) (setf (tests ob) (append (tests ob) (list new-test)))) (defmethod run-on-test-results ((ob test-suite) (result test-results) &key (handle-errors t)) (mapc #'(lambda (composite) ;;test-case or suite (run-on-test-results composite result :handle-errors handle-errors)) (tests ob))) (defmethod named-test (name (suite test-suite)) (some (lambda (test-or-suite) (when (and (typep test-or-suite 'test-case) (equal name (name test-or-suite))) test-or-suite)) (tests suite))) (defmethod remove-test ((test test) (suite test-suite)) (setf (tests suite) (delete-if #'(lambda (existing-tests-or-suite) (cond ((typep existing-tests-or-suite 'test-suite) (eq existing-tests-or-suite test)) ((typep existing-tests-or-suite 'test-case) (eql (name existing-tests-or-suite) (name test))))) (tests suite)))) ;; Dynamic test 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) (when (and (> (length (symbol-name s)) 5) (string-equal "test-" (subseq (symbol-name s) 0 5)) (fboundp s) (typep (symbol-function s) 'generic-function) (ignore-errors (plusp (length (compute-applicable-methods (ensure-generic-function s) (list instance)))))) (push s res))) (nreverse res))) (defmacro def-test-method (method-name ((instance-name class-name) &key (run t)) &body method-body) `(let ((,instance-name (make-instance ',class-name :name ',method-name))) (setf (method-body ,instance-name) #'(lambda() ,@method-body)) (add-test (suite ,instance-name) ,instance-name) (when ,run (textui-test-run ,instance-name)))) cl-xlunit-0.6.3/tcase.lisp0000644000175000017500000000552410667175533014464 0ustar kevinkevin;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; ID: $Id$ ;;;; Purpose: Test fixtures for XLUnit ;;;; ;;;; ************************************************************************* (in-package #:xlunit) (defclass test () ()) (defclass test-case (test) ((existing-suites :initform nil :accessor existing-suites :allocation :class) (method-body :initarg :method-body :accessor method-body :initform nil :documentation "A function designator which will be applied to this instance to perform that test-case.") (name :initarg :name :reader name :initform "" :documentation "The name of this test-case, used in reports.") (description :initarg :description :reader description :documentation "Short description of this test-case, uses in reports") (suite :initform nil :accessor suite :initarg :suite)) (:documentation "Base class for test-cases.")) (defmethod initialize-instance :after ((ob test-case) &rest initargs) (declare (ignore initargs)) (if (null (existing-suites ob)) (setf (existing-suites ob) (make-hash-table))) ;;hash singleton (unless (gethash (type-of ob) (existing-suites ob)) (setf (gethash (type-of ob) (existing-suites ob)) (make-instance 'test-suite))) ;;specifi suite singleton (setf (suite ob) (gethash (type-of ob) (existing-suites ob)))) (defgeneric set-up (test) (:documentation "Method called before performing a test, should set up the environment the test-case needs to operate in.")) (defmethod set-up ((test test-case)) ) (defgeneric tear-down (test) (:documentation "Method called after performing a test. Should reverse everything that the setup method did for this instance.")) (defmethod tear-down ((test test-case)) ) (defmethod run ((ob test) &key (handle-errors t)) "Generalized to work on test-case and test-suites" (let ((res (make-test-results))) (run-on-test-results ob res :handle-errors handle-errors) res)) (defmethod run-on-test-results ((test test-case) result &key (handle-errors t)) (start-test test result) (run-protected test result :handle-errors handle-errors) (end-test test result)) (defmethod run-base ((test test-case)) (set-up test) (unwind-protect (run-test test) (tear-down test))) (defmethod run-test ((test test-case)) (funcall (method-body test))) (defmethod run-protected ((test test-case) res &key (handle-errors t)) (if handle-errors (handler-case (run-base test) (assertion-failed (condition) (add-failure res test condition)) (serious-condition (condition) (add-error res test condition))) (run-base test)) res) cl-xlunit-0.6.3/tests.lisp0000644000175000017500000001232010667175533014517 0ustar kevinkevin;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Id: $Id$ ;;;; Purpose: Self Test suite for XLUnit ;;;; ;;;; ************************************************************************* (in-package #:cl-user) (defpackage #:xlunit-tests (:use #:cl #:xlunit) (:export #:do-tests)) (in-package #:xlunit-tests) (define-condition test-condition (error) ()) ;; Helper test fixture (defclass was-run (test-case) ((log :accessor ws-log))) (defmethod set-up ((self was-run)) (setf (ws-log self) "setup ")) (defmethod tear-down ((self was-run)) (setf (ws-log self) (concatenate 'string (ws-log self) "teardown "))) (def-test-method test-method ((self was-run) :run nil) (setf (ws-log self) (concatenate 'string (ws-log self) "test-method "))) (def-test-method test-broken-method ((self was-run) :run nil) (assert-equal pi (/ 22 7))) (def-test-method test-not-eql ((self was-run) :run nil) (assert-not-eql (cons t t) (cons t t))) (def-test-method test-eql ((self was-run) :run nil) (let ((obj (cons t t))) (assert-eql obj obj))) (def-test-method test-error-method ((self was-run) :run nil) (error "Err")) (def-test-method test-condition-without-cond ((self was-run) :run nil) (assert-condition 'error (list 'no-error))) #+ignore (def-test-method test-not-condition-with-cond ((self was-run) :run nil) (assert-not-condition 'test-condition (signal 'test-condition))) ;;; Second helper test case (defclass test-two-cases (test-case) ()) (def-test-method test-1 ((self test-two-cases) :run nil) (assert-true t)) (def-test-method test-2 ((self test-two-cases) :run nil) (assert-false nil)) ;;; Main test fixture (defclass test-case-test (test-case) ()) (def-test-method test-template-method ((self test-case-test) :run nil) (let ((test (named-test 'test-method (get-suite was-run)))) (run test) (assert-equal (ws-log test) "setup test-method teardown "))) (def-test-method test-results ((self test-case-test) :run nil) (assert-equal "1 run, 0 erred, 0 failed" (summary (run (named-test 'test-method (get-suite was-run)))))) (def-test-method test-eql ((self test-case-test) :run nil) (assert-equal "1 run, 0 erred, 0 failed" (summary (run (named-test 'test-eql (get-suite was-run)))))) (def-test-method test-not-eql ((self test-case-test) :run nil) (assert-equal "1 run, 0 erred, 0 failed" (summary (run (named-test 'test-not-eql (get-suite was-run)))))) (def-test-method test-fn ((self test-case-test) :run nil) (let ((test (make-instance 'test-case :name 'test-fn :method-body (lambda () (declare (ignore test)) (assert-equal 10 10))))) (assert-equal "1 run, 0 erred, 0 failed" (summary (run test))))) (def-test-method test-failed-result ((self test-case-test) :run nil) (assert-equal "1 run, 0 erred, 1 failed" (summary (run (named-test 'test-broken-method (get-suite was-run)))))) (def-test-method test-error-result ((self test-case-test) :run nil) (assert-equal "1 run, 1 erred, 0 failed" (summary (run (named-test 'test-error-method (get-suite was-run)))))) (def-test-method test-suite ((self test-case-test) :run nil) (let ((suite (make-instance 'test-suite)) (result (make-test-results))) (add-test suite (named-test 'test-method (get-suite was-run))) (add-test suite (named-test 'test-broken-method (get-suite was-run))) (run-on-test-results suite result) (assert-equal "2 run, 0 erred, 1 failed" (summary result)))) (def-test-method test-dynamic-suite ((self test-case-test) :run nil) (assert-equal "2 run, 0 erred, 0 failed" (summary (run (get-suite test-two-cases))))) (def-test-method test-condition ((self test-case-test) :run nil) (assert-condition 'test-condition (error 'test-condition))) (def-test-method test-condition-without-cond ((self test-case-test) :run nil) (assert-equal "1 run, 0 erred, 1 failed" (summary (run (named-test 'test-condition-without-cond (get-suite was-run)))))) #+ignore (def-test-method test-not-condition ((self test-case-test) :run nil) (assert-not-condition 'test-condition (progn))) #+ignore (def-test-method test-not-condition-with-cond ((self test-case-test) :run nil) (assert-equal "1 run, 0 erred, 1 failed" (summary (run (named-test 'test-not-condition-with-cond (get-suite was-run)))))) #+ignore (textui-test-run (get-suite test-case-test)) (defun do-tests () (or (was-successful (run (get-suite test-case-test))) (error "Failed tests"))) cl-xlunit-0.6.3/textui.lisp0000644000175000017500000000247710667175533014713 0ustar kevinkevin;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; ID: $Id$ ;;;; Purpose: Text UI for Test Runner ;;;; ;;;; ************************************************************************* (in-package #:xlunit) ;;; Test Runners (defclass textui-test-runner (test-listener) ((ostream :initform nil :accessor ostream :initarg :ostream)) (:default-initargs :ostream *standard-output*)) (defmethod add-error ((ob textui-test-runner) test-case condition) (declare (ignore test-case condition)) (format (ostream ob) "E")) (defmethod add-failure ((ob textui-test-runner) test-case condition) (declare (ignore test-case condition)) (format (ostream ob) "F")) (defmethod start-test ((ob textui-test-runner) test-case) (declare (ignore test-case)) (format (ostream ob) ".")) (defmethod textui-test-run ((ob test)) (let ((test-runner (make-instance 'textui-test-runner)) (result (make-instance 'test-results)) (start-time (get-internal-real-time))) (add-listener result test-runner) (run-on-test-results ob result) (print-results test-runner result (/ (- (get-internal-real-time) start-time) internal-time-units-per-second)) result)) cl-xlunit-0.6.3/xlunit.asd0000644000175000017500000000345610667175533014512 0ustar kevinkevin;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: xlunit.asd ;;;; Purpose: ASDF definition file for Xlunit ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Aug 2003 ;;;; ;;;; $Id$ ;;;; ************************************************************************* (defpackage #:xlunit-system (:use #:asdf #:cl)) (in-package #:xlunit-system) (defsystem xlunit :name "xlunit" :author "Kevin Rosenberg based on work by Craig Brozensky" :maintainer "Kevin M. Rosenberg " :licence "BSD" :description "Extreme Lisp Testing Suite" :long-description "The XLUnit package is toolkit for building test suites. It is based on the XPTest package by Craig Brozensky and the JUnit package by Kent Beck." :properties ((#:author-email . "kevin@rosenberg.net") ((#:albert #:output-dir) . "albert-docs/") ((#:albert #:formats) . ("docbook")) ((#:albert #:docbook #:template) . "book") ((#:albert #:docbook #:bgcolor) . "white") ((#:albert #:docbook #:textcolor) . "black")) :serial t :components ((:file "package") (:file "assert") (:file "tcase") (:file "listener") (:file "result") (:file "suite") (:file "textui") (:file "printer") )) (defmethod perform ((o test-op) (c (eql (find-system 'xlunit)))) (operate 'load-op 'xlunit-tests) (operate 'test-op 'xlunit-tests :force t)) (defsystem xlunit-tests :depends-on (xlunit) :components ((:file "tests"))) (defmethod perform ((o test-op) (c (eql (find-system 'xlunit-tests)))) (operate 'load-op 'xlunit-tests) (or (funcall (intern (symbol-name '#:do-tests) (find-package '#:xlunit-tests))) (error "test-op failed")))