;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:        src.lisp
;;;; Purpose:     eXtreme Lisp Test Suite
;;;; Authors:     Kevin Rosenberg and Craig Brozefsky
;;;;
;;;; $Id: src.lisp,v 1.3 2003/08/04 09:50:33 kevin Exp $
;;;; *************************************************************************

(in-package #:xlunit)


(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-condition (simple-condition) 
  ()
  (:documentation "Base class for all test failures."))

(defclass test-failure ()
  ((failed-test :initarg :failed-test :reader failed-test)
   (thrown-condition :initarg :thrown-condition :reader thrown-condition)))

(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 is-failure ((failure test-failure))
  (typep (thrown-condition failure) 'test-failure-condition))

(defun failure (format-str &rest args)
  "Signal a test failure and exit the test."
  (signal 'test-failure-condition
	  :format-control format-str
	  :format-arguments args))

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

(defun assert-equal (v1 v2 &optional msg)
  (unless (equal v1 v2)
    (failure "Test equal: ~s ~s" v1 v2)))

(defun assert-true (v &optional msg)
  (unless v
    (failure "Test true: ~s [~A]" v (if msg msg ""))))

(defun assert-false (v &optional msg)
  (when v
    (failure "Test false ~A" (if msg msg ""))))


(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)))

(defclass test-result ()
  ((test :initarg :test :reader result-test)
   (count :initform 0 :accessor test-count)
   (failures :initarg :failures :reader test-failures :initform nil)
   (errors :initarg :errors :reader test-errors :initform nil))
  (:documentation "The result of applying a test"))

(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 setup-testsuite-named (name)
  (declare (ignore name))
  t)

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

(defmethod run-test ((suite test-suite) (result test-result)
		     &key (handle-errors t))
  (setup-testsuite-named (slot-value suite 'name))
  (dolist (test (tests suite))
    (run-test test result :handle-errors handle-errors))
  (teardown-testsuite-named (slot-value suite 'name))
  (values))

(defmethod run-test ((test test-fixture) result &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."
  (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-thunk test) test))))
	   (if (typep res 'test-failure-condition)
	       (push (make-instance 'test-failure
		       :failed-test test
		       :thrown-condition res)
		     failures)))
	 (test-failure-condition (failure)
				 (push (make-instance 'test-failure
					 :failed-test test
					 :thrown-condition failure)
				       failures))
	 (error (err)
		(push (make-instance 'test-failure 
			:failed-test test 
			:thrown-condition err)
		      errors)))
	(if handle-errors
	    (handler-case
		(teardown test)
	      (error (err)
		(push 
		 (make-instance 'test-failure
		   :failed-test test :thrown-condition err)
		 errors)))
	  (teardown test))))
  (values))


(defun make-test (fixture name &key test-thunk test-suite 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 (make-instance fixture
		   :test-name (string name)
		   :test-thunk 
		   (if(and (symbolp name) (null test-thunk))
		       name
		     test-thunk)
		   :description description)))
       (if test-suite (add-test newtest test-suite))
       newtest))
	   
(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 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 was-successful ((result test-result))
  (and (null (test-failures result))
       (null (test-errors result))))

(defmethod text-testrunner ((suite test-suite) &key (stream t)
						    (handle-errors t))
  (let ((result (make-instance 'test-result))
	(start-time (get-internal-real-time)))
    (run-test suite result :handle-errors handle-errors)
    (let ((seconds (/ (- (get-internal-real-time) start-time)
		      internal-time-units-per-second)))
      (result-printer result seconds stream))))

(defun result-printer (result seconds stream)
  (format stream "~&Time: ~D~%~%" (coerce seconds 'float))
  (print-defects (test-errors result) "error" stream)
  (print-defects (test-failures result) "failure" stream)
  (if (was-successful result)
      (format stream "OK (~D tests)~%" (test-count result))
    (progn
      (format stream "~%FAILURES!!!~%")
      (format stream "Tests run: ~D, Failures: ~D, Errors: ~D~%"
	      (test-count result) (length (test-failures result))
	      (length (test-errors result))))))

(defun print-defects (defects type stream)
  (when defects
    (let ((count (length defects)))
      (if (= count 1)
	  (format stream "~&There was ~D ~A:~%" count type)
	(format stream "~&There were ~D ~As:~%" count type))
      (dotimes (i count)
	(let ((defect (nth i defects)))
	  (format stream "~&~D) ~A " i (class-name
					(class-of (failed-test defect))))
	  (apply #'format stream (simple-condition-format-control 
				  (thrown-condition defect))
		 (simple-condition-format-arguments 
		  (thrown-condition defect)))
	  (fresh-line stream))))))

(defmethod summary ((result test-result))
  (format nil "~D run, ~D errored, ~D failed"
	  (test-count result) (length (test-errors result))
	  (length (test-failures result))))

;;; 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 (class-name (class-of fixture)) 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)
      (when (and (> (length (symbol-name s)) 5)
		 (string-equal "test-" (subseq (symbol-name s) 0 5))
		 (fboundp s)
		 (typep (symbol-function s) 'generic-function)
		 (plusp (length (compute-applicable-methods 
				 (ensure-generic-function s)
				 (list instance)))))
	(push s res)))
    (nreverse res)))