;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; ID:      $Id: suite.lisp,v 1.2 2003/08/04 12:16:13 kevin Exp $
;;;; Purpose: Suite functions for XLUnit
;;;;
;;;; *************************************************************************

(in-package #:xlunit)

(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)
		     &key (result (make-instance 'test-result))
		     (handle-errors t))
  (setup-testsuite-named (slot-value suite 'name))
  (dolist (test (tests suite))
    (run-test test :result result :handle-errors handle-errors))
  (teardown-testsuite-named (slot-value suite 'name))
  result)

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


;; Dynamic test suite

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


;;; Test Runners

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