X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;ds=sidebyside;f=tests%2Ftest-init.lisp;h=2f36da21643a81458c34872dd227a8085f37d422;hb=d26a044593b10e62d1ba1c7b80266f55bc100d5d;hp=28ae58709f3d37628accf4ecd7040ec5f5ed8e88;hpb=ec9b352b8205e4204a06797f98970b03cf532ab2;p=clsql.git

diff --git a/tests/test-init.lisp b/tests/test-init.lisp
index 28ae587..2f36da2 100644
--- a/tests/test-init.lisp
+++ b/tests/test-init.lisp
@@ -340,20 +340,24 @@
 (defvar *error-count* 0)
 (defvar *error-list* nil)
 
-(defun run-tests-append-report-file (report-file)
-  (let* ((report-path (etypecase report-file
+(defun run-function-append-report-file (function report-file)
+    (let* ((report-path (etypecase report-file
 			(pathname report-file)
 			(string (parse-namestring report-file))))
 	 (sexp-report-path (make-pathname :defaults report-path
 					  :type "sexp")))
-  (with-open-file (rs report-path :direction :output
-		      :if-exists :append
+      (with-open-file (rs report-path :direction :output
+			  :if-exists :append
 		      :if-does-not-exist :create)
-    (with-open-file (srs sexp-report-path :direction :output
-			 :if-exists :append
-			 :if-does-not-exist :create)
-      (run-tests :report-stream rs :sexp-report-stream srs)))))
-    
+	(with-open-file (srs sexp-report-path :direction :output
+			     :if-exists :append
+			     :if-does-not-exist :create)
+	  (funcall function :report-stream rs :sexp-report-stream srs)))))
+
+(defun run-tests-append-report-file (report-file)
+  (run-function-append-report-file 'run-tests report-file))
+
+
 (defun run-tests (&key (report-stream *standard-output*) (sexp-report-stream nil))
   (let ((specs (read-specs))
 	(*report-stream* report-stream)
@@ -374,35 +378,39 @@
     (when (db-type-spec db-type specs)
       (clsql:initialize-database-type :database-type db-type))))
 
-(defun do-tests-for-backend (db-type spec)
-  (test-connect-to-database db-type spec)
-
-  (unwind-protect
-      (multiple-value-bind (test-forms skip-tests)
-	  (compute-tests-for-backend db-type *test-database-underlying-type*)
-	
-	(format *report-stream* 
-		"~&
+(defun write-report-banner (report-type db-type stream)
+  (format stream
+	  "~&
 ******************************************************************************
-***     CLSQL Test Suite begun at ~A
+***     CLSQL ~A begun at ~A
 ***     ~A
 ***     ~A on ~A
 ***     Database ~A backend~A.
 ******************************************************************************
-" 
-		(clsql-base:format-time 
-		 nil 
-		 (clsql-base:utime->time (get-universal-time)))
-		(lisp-implementation-type)
-		(lisp-implementation-version)
-		(machine-type)
-		db-type
-		(if (not (eq db-type *test-database-underlying-type*))
-		    (format nil " with underlying type ~A" 
-			    *test-database-underlying-type*)
-		  "")
-		)
-	
+"
+	  report-type
+	  (clsql-base:format-time 
+	   nil 
+	   (clsql-base:utime->time (get-universal-time)))
+	  (lisp-implementation-type)
+	  (lisp-implementation-version)
+	  (machine-type)
+	  db-type
+	  (if (not (eq db-type *test-database-underlying-type*))
+	      (format nil " with underlying type ~A" 
+		      *test-database-underlying-type*)
+	      "")
+	  ))
+
+(defun do-tests-for-backend (db-type spec)
+  (test-connect-to-database db-type spec)
+  
+  (unwind-protect
+       (multiple-value-bind (test-forms skip-tests)
+	  (compute-tests-for-backend db-type *test-database-underlying-type*)
+	 
+	 (write-report-banner "Test Suite" db-type *report-stream*)
+	 
 	(test-initialise-database)
 	
 	(regression-test:rem-all-tests)
@@ -435,6 +443,7 @@
 
 
 (defun compute-tests-for-backend (db-type db-underlying-type)
+  (declare (ignorable db-type))
   (let ((test-forms '())
 	(skip-tests '()))
     (dolist (test-form (append (test-basic-forms)